Option Explicit

Sub test()
Dim i&, dic As Object, imax&, dic2 As Object
Dim arr(), arr1$(), lrow&, ikey, x&
Set dic = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
On Error Resume Next
With Лист1
    lrow = .Cells(.Rows.Count, 1).End(xlUp).Row
    For i = 1 To lrow
        dic.Item(CStr(.Cells(i, 1))) = dic.Item(CStr(.Cells(i, 1))) + 1
        dic2.Item(CStr(.Cells(i, 1))) = dic2.Item(CStr(.Cells(i, 1))) & .Cells(i, 2) & " "
    Next i
    imax = Application.Max(dic.items)
    i = 0
    ReDim arr(1 To dic.Count, 1 To imax + 1)
    For Each ikey In dic2.keys
        i = i + 1: arr(i, 1) = ikey
        arr1 = Split(Trim(dic2.Item(ikey)), " ")
        For x = 2 To UBound(arr, 2)
            arr(i, x) = arr1(x - 2)
        Next x
    Next ikey
    On Error GoTo 0
    .[d1].Resize(UBound(arr), UBound(arr, 2)) = arr
End With
End Sub