Sub tt()
    Dim a(), i&, ii&, k, arr

    Application.ScreenUpdating = False

    a = [a1].CurrentRegion.Value

    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a)
            .Item(a(i, 1)) = .Item(a(i, 1)) & a(i, 2) & "|"
        Next

        ii = 1
        For Each k In .keys
            ii = ii + 1
            Cells(ii, 9) = k
            arr = Split(.Item(k), "|")
            Cells(ii, 10).Resize(1, UBound(arr)) = arr
        Next

    End With

    Application.ScreenUpdating = True

End Sub