(VBA) How to delete dupicate row and sum corresponding values to right columns?

问题

I have an 'test' excel where I have 4 columns from A-D. If A and B values are same with another row, macro deletes 'older' row and sums corresponding values to another row in to columns C and 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

EDITED! So here row 1 and row 4 had same values on columns A and B so macro deletes row 1 and adds row 1 column C D values to row 4 columns C D !!

I have tried with this code, but now it only adds values only to column D and not also to column C.. I really dont know how to do it.. Here is my code:

    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

Actual excel has almost 2000 rows.. so I also hope this macro is fast enough for that. Thank you for your help and Im sorry for my English. I hope you understand :)

回答1:

Oke, the answer is heavily based on this recent answer I have given. There is another clever answer in the same thread by @DisplayName that you might want to utilize, but here is my take on a understandable way of using a class module and a dictionary.

Let's assume the following input data starting from A1:

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

First create a class module and name it, e.g.: clssList with the following code in it:

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

Second create a module, and put the following code in it:

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

It's a bit extensive but I have written in such a way it will be easy to understand what is going on. It should be prety fast for 20000 records.

The above results in a matrix starting from range F1 looking like:

Running a speed test on 100.000 rows returned a total elapsed time of around 3,4 seconds. 20.000 Records came down to around 1,8 seconds.

Another, shorter (written code, not speed) way would be to not use a class module and concatenate array items (with a small risk that the delimiter you will be using exists in a value). An example is shown in the link on the top. And I just see that @RonRosenFeld put an example up on how to use just that.

回答2:

I prefer to use a Dictionary object when looking for duplicates, and to work in VBA arrays when working with ranges. Adds significant speed to the code:

'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

This transformation can also be done using Power Query aka Get & Transform available in Excel 2010+

Get from Range/Table
Reverse Rows
Group by Columns 1 and 2
Aggregate with Sum function for columns 3 and 4

Reverse the rows

M-Code

let
    Source = Excel.CurrentWorkbook(){[Name="Table3"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"Column1", Int64.Type}, {"Column2", Int64.Type}, {"Column3", Int64.Type}, {"Column4", Int64.Type}}),
    #"Reversed Rows" = Table.ReverseRows(#"Changed Type"),
    #"Grouped Rows" = Table.Group(#"Reversed Rows", {"Column1", "Column2"}, {{"sumC", each List.Sum([Column3]), type number}, {"sumD", each List.Sum([Column4]), type number}}),
    #"Reversed Rows1" = Table.ReverseRows(#"Grouped Rows")
in
    #"Reversed Rows1"

And, if you didn't care about the order, you could just use a regular Pivot Table.

来源：https://stackoverflow.com/questions/58391896/vba-how-to-delete-dupicate-row-and-sum-corresponding-values-to-right-columns

标签

excel

vba

sum

duplicates