VBA Duplicate Row Sum and Delete Macro

Question

I'm attempting to create (modify) a macro that will combine any duplicated rows in a table while summing the numbers in the last column, then creating a new summarized table below.

The problem I'm having is that only the first duplicated row is being summed. This value then appears in all of the rows below.

Here's a pic of what I'm trying to explain: Example Table - five Columns

I would be extremely grateful if someone could show me how to modify the below code to correct this!

Sub CombineDupesV3()

Dim x       As Long
Dim r       As Long
Dim arr()   As Variant
Dim dic     As Object
Const DELIM As String = "|"

Set dic = CreateObject("Scripting.Dictionary")

x = Cells(Rows.Count, 1).End(xlUp).Row
arr = Cells(1, 1).Resize(x, 5).Value


For x = LBound(arr, 1) + 1 To UBound(arr, 1)
    
    If dic.exists(arr(x, 1)) Then
        arr(x, 5) = arr(x, 5) + CDbl(Split(dic(arr(x, 1)), DELIM)(3))
        
    Else
        dic(arr(x, 1)) = arr(x, 2) & DELIM & arr(x, 3) & DELIM & arr(x, 4) & DELIM & arr(x, 5)
    End If
    dic(arr(x, 1)) = arr(x, 2) & DELIM & arr(x, 3) & DELIM & arr(x, 4) & DELIM & arr(x, 5)
    
    Debug.Print "X = " & x
Next x


r = UBound(arr, 1) + 2

Application.ScreenUpdating = False

Cells(r, 1).Resize(, 5).Value = Cells(1, 1).Resize(, 5).Value

r = r + 1

    
 For x = 0 To dic.Count - 1
    Cells(r + x, 1).Value = dic.keys()(x)
    Cells(r + x, 2).Resize(, 4).Value = Split(dic.items()(x), DELIM)
    Cells(r + x, 5).Value = CDbl(Cells(r, 5).Value)
    
    Debug.Print "R = " & r
Next x

Application.ScreenUpdating = True


Erase arr
Set dic = Nothing

End Sub

question from:https://stackoverflow.com/questions/65650398/vba-duplicate-row-sum-and-delete-macro

Answer 1

Waitting for answers