Объедините повторяющиеся строки и суммируйте значения, используя словарь

Question

У меня есть таблица, показанная ниже, на основе подсвеченного желтым столбца, мне нужно сложить подсвеченные зеленым столбцы.

Ожидаемый результат здесь:

Я сделал это, используя приведенный ниже код…

Sub test()
    lrow = ActiveSheet.Cells(ActiveSheet.Cells.Rows.Count, 1).End(xlUp).Row

    Set Rng = Range("A2:A" & lrow)

    For Each cell In Rng
        If Not IsEmpty(cell) Then
            a = cell
            b = cell.Offset(0, 1)
            c = cell.Offset(0, 5)
            r = cell.Row

            cnt = Application.WorksheetFunction.CountIf(Rng, cell)
            d = 0
            For i = 1 To cnt
                If Cells(r + i, 1) = a And Cells(r + i, 2) = b And Cells(r + i, 6) Then
                Cells(r, 7) = Cells(r + i, 7) + Cells(r, 7)
                Cells(r, 8) = Cells(r + i, 8) + Cells(r, 8)
                d = d + 1
                End If
            Next
            If d > 0 Then Range(Cells(r + 1, 1).Address, Cells(r + d, 1).Address).EntireRow.Delete                
        End If
    Next
End Sub

Я хочу сделать это с помощью словаря сценариев, которыйНовое для меня.Поскольку я новичок, я не могу изменить приведенный ниже пример кода, найденного в сети !!

Получил его с здесь

Sub MG02Sep59()
    Dim Rng As Range, Dn As Range, n As Long, nRng As Range
    Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
    With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
    For Each Dn In Rng
        If Not .Exists(Dn.Value) Then
            .Add Dn.Value, Dn
        Else
            If nRng Is Nothing Then Set nRng = Dn Else Set nRng = Union(nRng, Dn)
            .Item(Dn.Value).Offset(, 3) = .Item(Dn.Value).Offset(, 3) + Dn.Offset(, 3)
        End If
    Next
    If Not nRng Is Nothing Then nRng.EntireRow.Delete
    End With
End Sub

Может кто-нибудь помочьменя нет?с некоторыми примечаниями, если это возможно.

Answer 1

Вот как я это сделаю:

Option Explicit
Sub Test()

    Dim ws As Worksheet
    Dim arrData As Variant
    Dim i As Long, ConcatenateStr As String, Sum1 As Currency, Sum2 As Currency
    Dim DictSum1 As Scripting.Dictionary 'You need the Microsoft Scripting Runtime reference for this to work
    Dim DictSum2 As Scripting.Dictionary

    Set ws = ThisWorkbook.Sheets("SheetName") 'Change this to fit your sheet name
    Set DictSum1 = New Scripting.Dictionary 'This is how you initialize your dictionary
    Set DictSum2 = New Scripting.Dictionary

    'Store everything on your sheet into the array
    arrData = ws.UsedRange.Value 'this will get from A1 till ctrl+end cell I'd delete rows and columns that are blank

    'Loop through the array to fill the dictionary
    For i = 2 To UBound(arrData) '2 because row 1 are headers, UBound is the function to get the last item of your array like .count
        If arrData(i, 1) = vbNullString Then Exit For 'this will end the loop once finding an empty value on column A
        ConcatenateStr = arrData(i, 1) & arrData(i, 2) & arrData(i, 3) & arrData(i, 6) 'this is to work cleaner, each number is the number of the column concatenated
        Sum1 = arrData(i, 7) 'column Sum 1
        Sum2 = arrData(i, 8) 'column Sum 2
        If Not DictSum1.Exists(ConcatenateStr) Then 'For the column Sum 1
            DictSum1.Add ConcatenateStr, Sum1 'this will add the first item Key = Concatenate String and item = the money value
        Else
            DictSum1(ConcatenateStr) = DictSum1(ConcatenateStr) + Sum1 'this will sum the existing value on the dictionary + the current value of the loop
        End If

        If Not DictSum2.Exists(ConcatenateStr) Then 'For the column Sum 2
            DictSum2.Add ConcatenateStr, Sum2 'this will add the first item Key = Concatenate String and item = the money value
        Else
            DictSum2(ConcatenateStr) = DictSum2(ConcatenateStr) + Sum2 'this will sum the existing value on the dictionary + the current value of the loop
        End If
    Next i

    Erase arrData

    With ws
        .UsedRange.RemoveDuplicates Columns:=Array(1, 2, 3, 6), Header:=xlYes 'Again UsedRange will take everything, Columns as you can see are the ones highlighted in yellow
        arrData = .UsedRange.Value 'Store the results of deleting all the duplicates
        For i = 2 To UBound(arrData)  'Lets fill the array with the sums
            ConcatenateStr = arrData(i, 1) & arrData(i, 2) & arrData(i, 3) & arrData(i, 6)
            arrData(i, 8) = DictSum1(ConcatenateStr)
            arrData(i, 9) = DictSum2(ConcatenateStr)
        Next i
        .UsedRange.Value = arrData 'Paste back the array with all the sums
    End With

End Sub

Я прокомментировал код, но чтобы узнать больше о словарях, посмотрите этот замечательный учебник