Option Explicit
Sub test()
Dim tb#(), Rw&, i&, j&, r&
Rw = Cells(Rows.Count, 1).End(xlUp).Row
ReDim tb(2 To Cells(Rows.Count, 1).End(xlUp).Row, 1 To 3)
For i = 2 To UBound(tb)
tb(i, 1) = Cells(i, 1): tb(i, 2) = Cells(i, 2)
For j = 2 To i - 1
If tb(i, 1) = Cells(j, 1) Then
tb(i, 3) = j
If tb(i, 2) = Cells(j, 2) Then
tb(i, 3) = UBound(tb) + 1
End If
End If
Next j
Next i
r = 1
Cells(1, 4) = Cells(1, 1)
Cells(1, 5) = Cells(1, 2)
For i = 2 To UBound(tb)
If tb(i, 3) = 0 Then
r = r + 1
Cells(r, 4) = tb(i, 1)
Cells(r, 5) = tb(i, 2)
Else
If tb(i, 3) <> UBound(tb) + 1 Then
For j = 2 To r
If tb(i, 1) = Cells(j, 4) Then
Cells(j, 5) = Cells(j, 5) + tb(i, 2)
Exit For
End If
Next j
End If
End If
Next i
End Sub