Sub dddddd()
Dim rng As Range, tab1, tab2, tab3(), x%
Set rng = Range("A1:B" & Range("A65000").End(xlUp).Row)
tab1 = rng.Value
rng.Sort Key1:=Range("A2"), Order1:=xlAscending, _
Key2:=Range("B2"), Order2:=xlAscending, Header:=xlGuess
tab2 = rng.Value
ReDim Preserve tab3(1, 0 To x)
tab3(0, x) = tab2(2, 1)
tab3(1, x) = tab2(2, 2)
For i = 3 To UBound(tab2)
If tab2(i, 1) = tab2(i - 1, 1) Then
tab3(1, x) = tab3(1, x) & ";" & tab2(i, 2)
Else
x = x + 1
ReDim Preserve tab3(1, 0 To x)
tab3(0, x) = tab2(i, 1)
tab3(1, x) = tab2(i, 2)
End If
Next
Range("D1").Resize(UBound(tab3, 2) + 1, 2) = Application.Transpose(tab3)
rng.Value = tab1
End Sub