Sub test()
Dim a, i As Long, w, x As Object
a = Cells(1).CurrentRegion.Value
With CreateObject("System.Collections.SortedList")
For i = 2 To UBound(a, 1)
If Not .Contains(a(i, 4)) Then
.Item(a(i, 4)) = Array(a(i, 4), a(i, 2), a(i, 3))
Else
w = .Item(a(i, 4))
w(1) = w(1) + a(i, 2): w(2) = w(2) + a(i, 3)
.Item(a(i, 4)) = w
End If
Next
Set x = .Clone
End With
With Sheets.Add.Cells(1).Resize(, 3)
.Value = Application.Index(a, 1, [{4,2,3}])
For i = 0 To x.Count - 1
.Rows(i + 2).Value = x.GetByIndex(i)
Next
End With
End Sub