查找重复行并对列的值求和

Question

我有 18000 行和 26 列。

样本数据：

A(Name)     B(Mat_Num)  C(Items) D(group)   E(Summon)   F(Plant) G(Batch_num)
1.Ram       1235         HA1      Micro      545.5      1327      893A1
2.ram       12354        rt2      Senf       5678       0001      1063F
3.Joseph    12354        cf1      Macro      9844       0001      1063F
4.andreas   12354        dw1      HR         6633.95    0001      1063F
5.John      1235         ff1      Finance    22555.09   1327      893A1
6.Russel     987         ad1      Sales      6423       0001      jjg67
7.Holger      00         dd1      purchase   3333       1327      dd567
8.Gottfried   234        fa1      rot        663        345       45678

我必须根据列（B、F、G）查找重复的行。如果这三列的行相同，则将E列的单元格的值相加为一行，并删除重复的行以仅保留其中一行。

结果：

 A(Name)     B(Mat_Num)  C(Items) D(group)   E(Summon)   F(Plant) G(Batch_num)
1.Ram       1235         HA1      Micro      23101      1327      893A1
2.ram       12354        rt2      Senf       22155.95   0001      1063F

我浏览了一些网站和博客，想出了下面发布的代码。

Sub Sample()
    Dim LastRowcheck As Long, n1 As Long
    Dim DelRange As Range

    With Worksheets("Sheet1")
        LastRowcheck = .Range("A" & .Rows.Count).End(xlUp).Row

        For n1 = 1 To LastRowcheck
            If .Cells(n1, 1).Value = Cells(n1 + 1, 1).Value Then
                If DelRange Is Nothing Then
                    Set DelRange = .Rows(n1)
                Else
                    Set DelRange = Union(DelRange, .Rows(n1))
                End If
            End If
        Next n1

        If Not DelRange Is Nothing Then DelRange.Delete
    End With
End Sub

Answer 1

这应该很快解决它。最快可以将 18K 行数据处理成一个总和。

Sub Sum_and_Dedupe()
    With Worksheets("sheet1")
        'deal with the block of data radiating out from A1
        With .Cells(1, 1).CurrentRegion
            'step off the header and make one column wider
            With .Resize(.Rows.Count - 1, .Columns.Count + 1).Offset(1, 0)
                .Columns(.Columns.Count).Formula = "=sumifs(e:e, b:b, b2, f:f, f2, g:g, g2)"
                .Columns(5) = .Columns(.Columns.Count).Value
                .Columns(.Columns.Count).Delete
            End With

            'remove duplicates
            .RemoveDuplicates Columns:=Array(2, 6, 7), Header:=xlYes
        End With
        .UsedRange
    End With
End Sub

对于 18K 行随机数据，这需要大约 18 秒。您自己的结果会因硬件和软件而异，但这应该是大致的。

        
               ^{Sum_and_Dedupe()之前的样本数据}

        
               ^{Sum_and_Dedupe() 后的样本数据}

Answer 2

这里是“棒球场”#2

Sub main()
Dim helperRng As Range

With Worksheets("Sheet01")
    With .UsedRange
        Set helperRng = .Offset(, .Columns.Count + 1).Resize(, 1)
        With helperRng
            .FormulaR1C1 = "=concatenate(RC2, RC6, RC7)"
            .Offset(, 1).FormulaR1C1 = "=if(countif(R1C[-1]:RC[-1], RC[-1])=1,1,"""")"
            With .Offset(, 2)
                .FormulaR1C1 = "=sumif(C[-2], RC[-2],C5)"
                .Value = .Value
            End With
            .Offset(, 1).SpecialCells(xlCellTypeFormulas, xlTextValues).EntireRow.Delete
            Worksheets("Sheet01").Columns(5).Resize(.Rows.Count - 1).Offset(1).Value = .Offset(1, 2).Resize(.Rows.Count - 1).Value
            helperRng.Resize(, 3).Clear
        End With
    End With
End With

End Sub

只好奇哪个更快！

Answer 3

这可以使用数组和字典对象在 18 毫秒（有点夸张）内完成。我通过知道我的总和值在第 4 列中来简化函数。您可以调整其他列中多个值的代码。我正在从 1 个数组写入另一个数组（InAy 到 OutAy），字典确定行是否已经存在。魔法发生在字典的 Item 属性中。当写入新的 OutAy 行时，我将 item 属性值分配给行 (r)。然后当它已经存在时，我使用 item 属性值检索它写入 OutAy 的行 (r)：d.item(KeyIn) 然后我可以用现有值的总和更新 OutAy(r, c) 中的该值和新值“KeyVal”。

这个解决方法同sql查询聚合："Select a, b, c, sum(d) from data group by a, b, c"

注意：添加工具->对 Microsoft 脚本运行时的引用

    sub some()
     ...
     data = Range("WhereYourDataIs") 'create data array
     Range("WhereYourDataIs").clear 'assumes you'll output to same location
     data = RemoveDupes(data) 'removedupes and sum values
     Range("A2").Resize(UBound(data), UBound(data, 2)) = data 'A2 assumes your data headers begin in row 1, column 1
     ...
    End Sub

Function RemoveDupes(InAy As Variant) As Variant
    Dim d As Scripting.Dictionary
    Set d = New Scripting.Dictionary
    ReDim OutAy(1 To UBound(InAy), 1 To 4)
    r = 1

    For i = 1 To UBound(InAy)
        KeyIn = ""
        KeyVal = InAy(i, 4) 'the value field to sum/aggregate if exists
        For c = 1 To 3 'a, b, c metadata to roll up
            KeyIn = KeyIn & InAy(i, c)
        Next c
        If d.Exists(KeyIn) Then
            OutAy(d.item(KeyIn), 4) = OutAy(d.item(KeyIn), 4) + KeyVal 'the summation of value field for existing row in OutAy
            Else:
            d.Add KeyIn, r 'r is set as the item value referencing the row of the OutAy when it was first added. The reference is used when .Exists is true
            For c = 1 To 4
                OutAy(r, c) = InAy(i, c)
            Next c
            r = r + 1
        End If
    Next
    RemoveDupes = OutAy
End Function