Combine duplicate rows and sum the values using dictionary - excel

Question

I have a table as shown below,based on yellow highlighted column i need to sum green highlighted columns.
Expected output is here:
I have done it using the below code …
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
I want to do it using scripting dictionary, which is new for me. Since I'm a beginner, I'm unable to modify the below example code found in net!!
Got it from here
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
Can anyone help me out? with some notes if possible.

Answer 1

this is how I would do it:
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
I've commented the code, but to learn more about dictionaries check this awesome tutorial