option
Sub ertert()
Dim x, y(), i&, j&, k&, n&, s$

x = Range("A2:B" & Cells(Rows.Count, 1).End(xlUp).Row).Value
ReDim y(1 To UBound(x), 1 To 2)

On Error Resume Next
With New Collection
    For i = 1 To UBound(x)
        s = Trim$(x(i, 1))
        If Len(s) Then
            If IsEmpty(.Item(s)) Then
                k = k + 1: y(k, 1) = s: y(k, 2) = x(i, 2)
                .Add k, s
            Else
                n = .Item(s): y(n, 2) = y(n, 2) + x(i, 2)
            End If
        End If
    Next i
End With

If k > 1 Then [e2:f2].Resize(k).Value = y
End Sub