(VBA) Как удалить дублирующиеся строки и суммировать соответствующие значения в правых столбцах?

Question

У меня есть «тест» 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

EDITED! Так что здесь строки 1 и 4 имели одинаковые значения в столбцах A и B, поэтому макрос удаляет строку 1 и добавляет значения CD столбца строки 1 в строку 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 строк .. поэтому я такженадеюсь, что этот макрос достаточно быстр для этого. Спасибо за вашу помощь, и я извиняюсь за мой английский. Я надеюсь, вы понимаете:)

Answer 1

Я предпочитаю использовать объект 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

Это преобразование также можно выполнить с помощью Power Query aka Get & Transform, доступного в Excel 2010+

• Получить от Range/Table
• Обратные строки
• Группировать по столбцам 1 и 2
• Агрегировать с функцией Sum для столбцов 3 и 4

• Перевернуть строки

M-код

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"

И, если вы не заботитесь о заказе, вы можете просто использовать обычную сводную таблицу.

Answer 2

Ок, ответ в значительной степени основан на этом недавнем ответе, который я дал. В этой теме есть еще один умный ответ от @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 записей.

---

Приведенные выше результаты приводят к матрице, начиная с диапазона F1, которая выглядит следующим образом:

---

Выполнение теста скорости на 100 000 строк вернуло общее истекшее время около 3,4 секунды. 20.000 записей сократились до 1,8 секунд.

---

Другой, более короткий (записанный код, а не скорость) способ состоит в том, чтобы не использовать модуль класса и объединять элементы массива (с небольшим риском того, что используемый вами разделитель существует в значении). Пример показан в ссылке сверху. И я просто вижу, что @RonRosenFeld приводит пример того, как использовать именно это.