Sub Test()
Dim a, i As Long, ii As Long, txt As String
a = Cells(1).CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
txt = a(i, 1)
If Not .Exists(txt) Then
.Item(txt) = .Count + 1
For ii = 1 To UBound(a, 2)
a(.Count, ii) = a(i, ii)
Next ii
Else
a(.Item(txt), 3) = a(.Item(txt), 3) + a(i, 3)
End If
Next i
i = .Count
End With
[H2].Resize(i, UBound(a, 2)) = a
End Sub