Sub es()
Dim t(), i As Long, m As Object, c As Byte, x as long
Set m = CreateObject("Scripting.Dictionary")
t = Range("b8:f" & Cells(Rows.Count, 2).End(3).Row)
For i = 1 To UBound(t)
If m.Exists(t(i, 1)) Then
For c = 2 To 5: t(m(t(i, 1)), c) = t(m(t(i, 1)), c) + t(i, c): Next c
Else
x = x + 1
For c = 1 To 5: t(x, c) = t(i, c): Next c: m(t(i, 1)) = x
End If
Next i
Range("b8:f" & Cells(Rows.Count, 2).End(3).Row).ClearContents
[b8].Resize(x, 5) = t
Range("b8:f" & Cells(Rows.Count, 2).End(3).Row).Sort [b8], xlAscending, Header:=0
End Sub