最初の列が値vbaを繰り返す合計行

Question

VBAを使用してExcelで重複するセル値をマージしようとしています。データの例を次に示します。

data: 
C 10,00 6,00 60,00% 0,00 20,00 12,00 60,00% 
A 200,00 8,00 4,00% 0,00 20,00 12,00 60,00% 
C 125,00 6,00 4,80% 0,00 12,00 10,00 83,33% 
A 158,00 4,00 2,53% 0,00 10,00 8,00 80,00% 
A 300,00 8,00 2,67% 0,00 20,00 12,00 60,00% 
B 80,00 3,55 4,44% 0,00 10,00 5,00 50,00% 
A 135,00 64,00 47,41% 0,00 10,00 2,00 20,00% 
C 12,00 6,00 50,00% 0,00 10,00 4,00 40,00% 
result:      
A 793,00 84,00 10,59% 0,00 60,00 34,00 56,67% 
B 80,00 3,55 4,44% 0,00 10,00 5,00 50,00% 
C 147,00 18,00 12,24% 0,00 42,00 26,00 61,90% 

私は何かをマージせずに辞書で多くのソリューションを試しました。 私は必要なマージソリューションをどのように手に入れることができるでしょうか？

Answer 1

辞書を使用して重複を破棄し、すべての数値列を合計するバージョンです。サイドノート：VBAの機能が本当に必要な場合を除いて、私はExcelの標準ピボットテーブルを見てみることをお勧めします。

Sub merge() 

    ' temporary store of merged rows 
    Dim cMerged As New Collection 

    ' data part of the table 
    Dim data As Range 
    Set data = ActiveSheet.[a2:h9] 

    Dim rw As Range ' current row 
    Dim c As Range ' temporary cell 

    Dim key As String 
    Dim arr() As Variant 

    Dim i As Long 
    Dim isChanged As Boolean 

    For Each rw In data.Rows 
     key = rw.Cells(1) ' the first column is key 

     If Not contains(cMerged, key) Then 
      ' if this is new key, just add it 
      arr = rw 
      cMerged.Add arr, key 
     Else 
      ' if key exists - extract, add and replace 
      arr = cMerged(key) 

      ' iterate through cells in current and stored rows, 
      ' and add all numeric fields 
      i = 1 
      isChanged = False 
      For Each c In rw.Cells 
       If IsNumeric(c) Then 
        arr(1, i) = arr(1, i) + c 
        isChanged = True 
       End If 
       i = i + 1 
      Next 

      ' collections in vba are immutable, so if temp row 
      ' was changed, replace it in collection 
      If isChanged Then 
       cMerged.Remove key 
       cMerged.Add arr, key 
      End If 
     End If 
    Next 

    ' output the result 
    Dim rn As Long, rv As Variant 
    Dim cn As Long, cv As Variant 

    Dim arrOut() As Variant 
    ReDim arrOut(1 To cMerged.Count, 1 To UBound(cMerged(1), 2)) 

    rn = 1: cn = 1 
    For Each rv In cMerged 
     For Each cv In rv 
      arrOut(rn, cn) = cv 
      cn = cn + 1 
     Next 
     rn = rn + 1: cn = 1 
    Next 

    ActiveSheet.[a12].Resize(UBound(arrOut), UBound(arrOut, 2)) = arrOut 

End Sub 

' function that checks if the key exists in a collection 
Function contains(col As Collection, key As String) As Boolean 
    On Error Resume Next 
    col.Item key 
    contains = (Err.Number = 0) 
    On Error GoTo 0 
End Function