对第一列重复值 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