Option Explicit

Sub tt()
      Dim a(), i&, ii&, x&, t$, el, elel
      Dim bb&, cc&, dd&, lShNewWBCount&

      With Application
          .ScreenUpdating = False
          lShNewWBCount = .SheetsInNewWorkbook
          .SheetsInNewWorkbook = 3
      End With

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

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

          'перебор словаря/коллекций
          For Each el In .keys    'перебор ключей
              ii = 0    'обнуляем счётчик его строк
              For Each elel In .Item(el)    'цикл по коллекции ключа
                  ii = ii + 1    'счётчик строк выгружаемого массива
                  Select Case ii
                  Case 1
                      bb = bb + 1
                      'цикл по строке, полученной из коллекции, копирование данных
                      For x = 1 To 2: b(bb, x) = a(elel, x): Next
                  Case 2
                      cc = cc + 1
                      'цикл по строке, полученной из коллекции, копирование данных
                      For x = 1 To 2: c(cc, x) = a(elel, x): Next
                  Case 3
                      dd = dd + 1
                      'цикл по строке, полученной из коллекции, копирование данных
                      For x = 1 To 2: d(dd, x) = a(elel, x): Next
                  End Select
              Next
          Next
            
          With Workbooks.Add()    'создаём книгу
              .Sheets(1).Cells(1).Resize(bb, 2) = b    'выгружаем массив
              .Sheets(2).Cells(1).Resize(cc, 2) = c    'выгружаем массив
              .Sheets(3).Cells(1).Resize(dd, 2) = d    'выгружаем массив
          End With

      End With

      With Application
          .SheetsInNewWorkbook = lShNewWBCount
          .ScreenUpdating = True
      End With

End Sub