Option Explicit
Sub abc()
Dim a, i, j, m, p, sum
a = Range("a1:d" & [a1].End(xlDown).Row + 1).Value
Call bsort(a, 1, UBound(a) - 1, 1, 4, 1)
For i = 1 To UBound(a) - 1
If a(i, 1) <> a(i + 1, 1) Then
Call bsort(a, p + 1, i, 2, 4, 2)
For j = p + 1 To i
sum = sum + a(j, 3)
If a(j, 2) <> a(j + 1, 2) Or j = i Then
m = m + 1
a(m, 1) = a(i, 1): a(m, 2) = a(j, 2): a(m, 3) = sum: a(m, 4) = a(j, 4)
sum = 0
End If
Next
p = i
End If
Next
[f1].Resize(m, 4) = a
End Sub
Function bsort(a, first, last, left, right, key)
Dim i, j, k, t
For i = first To last - 1
For j = first To last + first - 1 - i
If a(j, key) > a(j + 1, key) Then
For k = left To right
t = a(j, k): a(j, k) = a(j + 1, k): a(j + 1, k) = t
Next
End If
Next
Next
End Function