Option Explicit

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

      a = Application.InputBox("Выделите исходный диапазон (с шапкой)", "Get Range", Type:=8).Value
      Application.ScreenUpdating = False

      'создали словарь, собрали уникальные с данными
      With CreateObject("Scripting.Dictionary")
          .comparemode = 1    'текстовое сравнение
          For i = 2 To UBound(a)    'цикл по данным
              t = a(i, 1)    'критерий, тут бы trim() ещё может нужен...
              ' если нет в словаре, добавляем с коллекцией
              If Not .exists(t) Then .Add t, New Collection
              For x = 2 To UBound(a, 2)
                  .Item(t).Add a(i, x)   'в коллекцию критерия добавляем данные
              Next
              m = Application.Max(m, .Item(t).Count)
          Next

          ReDim b(1 To .Count + 1, 1 To m + 1)
          b(1, 1) = a(1, 1)
          x = 0
          For i = 2 To UBound(b, 2) Step 3
          x = x + 1
              b(1, i) = a(1, 2) & x
              b(1, i + 1) = a(1, 3) & x
              b(1, i + 2) = a(1, 4) & x
          Next
          i = 1
          'перебор словаря/коллекций, выгрузка
          For Each el In .keys    'перебор ключей
              i = i + 1
              b(i, 1) = el
              ii = 1    'обнуляем счётчик его строк
              For Each elel In .Item(el)    'цикл по коллекции ключа
                  ii = ii + 1    'счётчик столбцов выгружаемого массива
                  b(i, ii) = elel
              Next
          Next
      End With

      With Workbooks.Add(1)    'создаём книгу
          .Sheets(1).Cells(1).Resize(UBound(b), m + 1) = b  'выгружаем массив
      End With

      Application.ScreenUpdating = True

End Sub