Sub a()
    Dim srcRn As Range, trgRn As Range, orgDic As Object
    Set srcRn = [B2:C10]
    Set orgDic = CreateObject("Scripting.Dictionary")
    For Each el In srcRn.Rows
        If Not orgDic.Exists(el.Cells(1).Value) Then
            orgDic(el.Cells(1).Value) = el.Cells(2)
        Else
            orgDic(el.Cells(1).Value) = orgDic(el.Cells(1).Value) & ";" & el.Cells(2)
        End If
    Next el
    Set trgRn = [H2].Resize(orgDic.Count, 2)
    For i = 0 To orgDic.Count - 1
        trgRn(i + 1, 1) = orgDic.Keys()(i)
        trgRn(i + 1, 2) = orgDic.Items()(i)
    Next i
    Range(trgRn.Cells(2, 1), trgRn.Cells(trgRn.Rows.Count, 2)).Sort Key1:=trgRn.Columns(1), Order1:=xlAscending, Header:=xlNo
End Sub