Fatal编程技术网
  • excel/
  • Excel （VBA）如何删除重复行并将相应的值相加到右列？

Excel （VBA）如何删除重复行并将相应的值相加到右列？

excel vba

Excel （VBA）如何删除重复行并将相应的值相加到右列？,excel,vba,sum,duplicates,Excel,Vba,Sum,Duplicates,我有一个“测试”excel，其中A-D有4列。如果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

我有一个“测试”excel，其中A-D有4列。如果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行的C列D值添加到第4行的C列D

我试过使用这段代码，但现在它只向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行。。所以我也希望这个宏足够快。谢谢你的帮助，我为我的英语感到抱歉。我希望你能理解：）

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

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

| 1 | 2 | 1 | 5 |
| 2 | 3 | 2 | 5 |
| 2 | 6 | 2 | 5 |
| 1 | 2 | 3 | 4 |
| 5 | 4 | 1 | 2 |
首先创建一个
类
模块并命名，例如：
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
Second创建一个模块，并将以下代码放入其中：

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
这是一个有点广泛，但我写了这样一种方式，它将很容易理解正在发生的事情。2万张唱片的速度应该很快

上述结果产生一个从范围
F1
开始的矩阵，如下所示：

在100000行上运行速度测试返回的总运行时间约为3,4秒。20000条记录下降到1.8秒左右

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

我更喜欢在查找重复项时使用Dictionary对象，在处理范围时使用VBA数组。为代码添加显著的速度：

'Set reference to Microsoft Scripting Runtime
'   or could use late binding if this is for distribution
Option Explicit
Sub deDup()
    Dim vSrc As Variant, vRes As Variant
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim myD As Dictionary, arrCD(1) As Long, skeyAB As String
    Dim I As Long, V As Variant
    
'declare worksheets and ranges
Set wsSrc = Worksheets("sheet3")
Set wsRes = Worksheets("sheet3")
    Set rRes = wsRes.Cells(5, 7)
    
'read source into variant array
With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 4).End(xlUp))
End With

'collect the data, add dups when needed
Set myD = New Dictionary
For I = 1 To UBound(vSrc, 1)
    skeyAB = vSrc(I, 1) & "|" & vSrc(I, 2)
    arrCD(0) = vSrc(I, 3)
    arrCD(1) = vSrc(I, 4)
    
    If Not myD.Exists(skeyAB) Then
        myD.Add Key:=skeyAB, Item:=arrCD
    Else
        arrCD(0) = arrCD(0) + myD(skeyAB)(0)
        arrCD(1) = arrCD(1) + myD(skeyAB)(1)
        
        'can only alter arrays outside of the dictionary
        'since we delete original entry and then add back the modified,
        '  the desired order will be retained
        myD.Remove (skeyAB)
        myD.Add skeyAB, arrCD
        
    End If
Next I

'create the output array
ReDim vRes(1 To myD.Count, 1 To 4)
I = 0

For Each V In myD.Keys
    I = I + 1
    vRes(I, 1) = Split(V, "|")(0)
    vRes(I, 2) = Split(V, "|")(1)
    vRes(I, 3) = myD(V)(0)
    vRes(I, 4) = myD(V)(1)
Next V

'write results to worksheet
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    .Style = "Output"
End With
    
End Sub

也可以使用Excel 2010中提供的
Power Query
aka
Get&Transform
完成此转换+

  • 从范围/表格中获取
  • 反向行
  • 按第1列和第2列分组
  • 对第3列和第4列使用Sum函数进行聚合

  • 倒排
M码
而且，如果您不关心顺序，您可以使用一个常规透视表。

您可以放一个示例数据片段，或者一个指向示例文件的链接吗？我编辑了我的文章。希望这一点现在更清楚了。也许是带字典的类模块？那应该很快。雷迪姆真的不是。我来看看是否能举一些简单的例子。谢谢@JvdV！我真的很感激：）这绝对也是一个不错的方法，罗恩。@JvdV-Tks。我经常使用类来处理复杂数据。正如您所展示的，它也可以在这里使用。您的数组方法可能同样好，如果不是更好的话。我不知道这是否会影响大文件的速度。@JvdV我从未测试过，所以不知道。这个过程也可以使用Power Query来完成（只是在我的答案中添加了这个）。@JvdV我最终意识到，十倍的速度变化与无意中的数据变化有关。实际上是0.4秒，而不是0.04秒。在进行计时时（请参阅下面的注释），我注意到您的例程返回的行的顺序与OP示例中的不同。他在重复行的最后一行显示他的总和，而你保留第一行并在那里求和。我将测试这两个代码，看看哪些代码更适合我的excel，并让您知道！：）我真的很感激。@JvdV您认为可以将此代码放入命令按钮中吗？当然可以。只是将宏分配到一个按钮。