Sub ss()
Dim d, arr, r As Integer
    [c:d].Clear
Set d = CreateObject("Scripting.Dictionary")
    r = Cells(Rows.Count, 1).End(xlUp).Row
    arr = Range("a1:b" & r)
For i = 1 To UBound(arr)
    If Not d.exists(arr(i, 1)) Then
d(arr(i, 1)) = arr(i, 2)
    Else
d(arr(i, 1)) = d(arr(i, 1)) & "+" & arr(i, 2)
    End If
Next
    [c1].Resize(d.Count, 1) = Application.Transpose(d.keys)
    [d1].Resize(d.Count, 1) = Application.Transpose(d.items)
End Sub