excel - （VBA）如何删除重复的行并将相应的值求和到右列？

问题描述

我有一个“测试”excel，其中有 4 列来自 AD。如果 A 和 B 值与另一行相同，则宏删除“旧”行并将对应值与另一行相加到 C 和 D 列中。

      A | B | C | D                         A | B | C | D 

 1    1 | 2 | 1 | 5                         2 | 3 | 2 | 5
 2    2 | 3 | 2 | 5                         2 | 6 | 2 | 5
 3    2 | 6 | 2 | 5      After Macro        1 | 2 | 4 | 9
 4    1 | 2 | 3 | 4      --------->         5 | 4 | 1 | 2
 5    5 | 4 | 1 | 2

已编辑！所以这里第 1 行和第 4 行在 A 列和 B 列上具有相同的值，因此宏删除第 1 行并将第 1 行列 CD 值添加到第 4 行列 CD ！

我已经尝试过使用这段代码，但现在它只将值添加到 D 列而不是 C 列。我真的不知道该怎么做。这是我的代码：

    Private Sub CommandButton1_Click()

    Dim i As Long, lrk As Long, tmp As Variant, vals As Variant

        With Worksheets(1)
            tmp = .Range(.Cells(2, "A"), .Cells(Rows.Count, "D").End(xlUp)).Value2
            ReDim vals(LBound(tmp, 1) To UBound(tmp, 1), 1 To 1)
            For i = LBound(vals, 1) To UBound(vals, 1)
                vals(i, 1) = Application.SumIfs(.Columns(3), .Columns(1), tmp(i, 1), Columns(2), tmp(i, 2), Columns(3), tmp(i, 3), Columns(4), tmp(i, 4))

            Next i
            .Cells(2, "D").Resize(UBound(vals, 1), UBound(vals, 2)) = vals
            With .Cells(1, "A").CurrentRegion
                .RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes
            End With
        End With
    End Sub

实际的 excel 有将近 2000 行.. 所以我也希望这个宏足够快。感谢您的帮助，我为我的英语感到抱歉。我希望你明白：）

标签： excelvbasumduplicates

好的，答案很大程度上基于我最近给出的答案。@DisplayName 在同一个线程中还有另一个聪明的答案，您可能想使用它，但这是我对使用类模块和字典的一种可以理解的方式的看法。

让我们假设以下输入数据从开始A1：

| 1 | 2 | 1 | 5 |
| 2 | 3 | 2 | 5 |
| 2 | 6 | 2 | 5 |
| 1 | 2 | 3 | 4 |
| 5 | 4 | 1 | 2 |

首先创建一个class模块并为其命名，例如：clssList其中包含以下代码：

Public Col1 As Variant
Public Col2 As Variant
Public Col3 As Variant
Public Col4 As Variant

其次创建一个模块，并将以下代码放入其中：

Sub BuildList()

Dim x As Long, arr As Variant, lst As clssList
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")

'Fill array variable from sheet
With Sheet1
    x = .Cells(.Rows.Count, 1).End(xlUp).Row
    arr = .Range("A1:D" & x).Value
End With

'Load array into dictionary with use of class
For x = LBound(arr) To UBound(arr)
    If Not dict.Exists(arr(x, 1) & "|" & arr(x, 2)) Then
        Set lst = New clssList
        lst.Col1 = arr(x, 1)
        lst.Col2 = arr(x, 2)
        lst.Col3 = arr(x, 3)
        lst.Col4 = arr(x, 4)
        dict.Add arr(x, 1) & "|" & arr(x, 2), lst
    Else 'In case column 2 is the same then add the values to the lst object
        dict(arr(x, 1) & "|" & arr(x, 2)).Col3 = dict(arr(x, 1) & "|" & arr(x, 2)).Col3 + arr(x, 3)
        dict(arr(x, 1) & "|" & arr(x, 2)).Col4 = dict(arr(x, 1) & "|" & arr(x, 2)).Col4 + arr(x, 4)
    End If
Next x

'Transpose dictionary into sheet3
With Sheet1
    x = 1
    For Each Key In dict.Keys
        .Cells(x, 6).Value = dict(Key).Col1
        .Cells(x, 7).Value = dict(Key).Col2
        .Cells(x, 8).Value = dict(Key).Col3
        .Cells(x, 9).Value = dict(Key).Col4
        x = x + 1
    Next Key
End With

End Sub

它有点广泛，但是我以这样的方式编写了它，这样很容易理解发生了什么。20000条记录应该很快。

上面的结果是一个从 range 开始的矩阵，F1如下所示：

在 100.000 行上运行速度测试返回的总经过时间约为 3.4 秒。20.000 条记录下降到大约 1.8 秒。

另一种更短（编写代码，而不是速度）的方法是不使用类模块并连接数组项（您将使用的分隔符存在于值中的风险很小）。顶部的链接中显示了一个示例。我只是看到@RonRosenFeld 举了一个例子来说明如何使用它。

excel - （VBA）如何删除重复的行并将相应的值求和到右列？

问题描述

解决方案

推荐阅读