Summe der Zeilen, in denen die Werte der ersten Spalte wiederholt werden vba

Question

Ich versuche, doppelte Zellwerte in Excel mithilfe von VBA zusammenzuführen (zu summieren). Hier ist ein Beispiel für die Daten:

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% 

Ich habe eine Menge Lösung mit Wörterbuch versucht, ohne etwas zu verschmelzen. Hat jemand irgendwelche Vorschläge, wie ich zu der Merge-Lösung kommen kann, die ich brauche?

Answer 1

Hier ist eine Version, die Dictionary verwendet, um Duplikate zu reduzieren und alle numerischen Spalten nach oben zu summieren. Randnotiz: Wenn Sie nicht "wirklich" die VBA-Funktion dafür benötigen, schlage ich vor, dass Sie sich auch Standard-Pivot-Tabellen in Excel ansehen - das ist genau das, was sie tun.

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