Option Explicit

Sub tt()
    Dim a(), i&, ii&, x&, t$, el, elel

    Application.ScreenUpdating = False

    'взяли данные
    a = [a1].CurrentRegion.Columns(1).Resize(, 2).Value

    'создали словарь, собрали уникальные с номерами строк
    With CreateObject("Scripting.Dictionary")
        .comparemode = 1    'текстовое сравнение
        On Error Resume Next
        For i = 2 To UBound(a)    'цикл по данным
            t = Trim(a(i, 1))   'критерий,
            'If Len(t) > 2 Then 'так можно отбросить пустые строки, нет в примере
            ' если нет в словаре, добавляем с коллекцией
            If Not .exists(t) Then .Add t, New Collection
            .Item(t).Add a(i, 2), a(i, 2)  'в коллекцию критерия добавляем элемент (уникальный)
            'End If
        Next
        On Error GoTo 0

        'перебор словаря/коллекций
        x = 10
        For Each el In .keys    'перебор ключей
            ReDim aa(1 To .Item(el).Count, 1 To 1)    ' создаём выгружаемый массив
            ii = 0    'обнуляем счётчик его строк
            For Each elel In .Item(el)    'цикл по коллекции ключа
                ii = ii + 1    'счётчик строк выгружаемого массива
                'цикл по строке, полученной из коллекции, копирование данных
                aa(ii, 1) = elel
            Next

            x = x + 1
            Cells(7, x) = el
            Cells(8, x).Resize(ii, 1) = aa

        Next
    End With

    Application.ScreenUpdating = True

End Sub