Как с одного столбца выдергнуть группы данных и снова сгрупировать в два столбца по порядку

Sub Peregruppirovka()
   Dim sh As Sheets, ws As Worksheet, rn As Range
   Dim shName As String, ext As String, rowsNum As Long
   Dim v As Variant, f As Boolean
'Блок получения ссылок на первичные данные.
   Set sh = ActiveWorkbook.Worksheets
   On Error GoTo ErrNoData
      Set ws = sh("Данные")
   On Error GoTo 0
   shName = ws.Range("A1")
   Set rn = ws.Range(ws.Range("A2"), ws.UsedRange.Cells(ws.UsedRange.Cells.Count))
   rowsNum = rn.Rows.Count + 1
'Блок создания нового листа и переноса на него данных.
   Set ws = sh.Add(After:=sh(sh.Count))
   On Error GoTo ErrNameAlreadyExists
      ws.Name = shName & ext
   On Error GoTo 0
   Application.ScreenUpdating = False
   With ws
      rn.Copy .Range("B2")
'Блок вычленения ФИО и переноса их в первый столбец.
      For Each rn In .Range(.Range("B2"), .Cells(rowsNum, 2))
         If UBound(Split(rn)) > 0 Then 'Если имеется больше 1 слова...
            f = True
            For Each v In Split(rn)
               If Not (v Like "[А-Я]*") Then 'проверяем, что все они заглавные.
                  f = False   'Если хотя бы одно не с заглавной - это не ФИО.
                  Exit For
               End If
            Next v
            If f Then rn.Cut rn.Offset(, -1) 'В случае успеха - ФИО в 1 столбец.
         End If
      Next rn
'Блок размножения ФИО.
      For Each rn In .Range(.Range("A2"), .Cells(rowsNum, 1))
         If IsEmpty(rn) Then rn = rn.Offset(-1)
      Next rn
'Финальные штрихи.
      .Range("A1:D1") = Array("ФИО", "Код", "Наименование", "Адрес")
      .Range("A1").AutoFilter
      .Columns("A:A").ColumnWidth = 31.29
      .Columns("B:B").ColumnWidth = 20.86
      .Columns("C:C").ColumnWidth = 36.14
      .Columns("D:D").ColumnWidth = 25.71
      .Columns("E:E").ColumnWidth = 7.43
   End With
   Application.CutCopyMode = False
   Application.ScreenUpdating = True
   Exit Sub
ErrNoData:
   MsgBox "Не могу найти лист с данными.", vbExclamation, "Ошибка"
   Exit Sub
ErrNameAlreadyExists:
   ext = Val(ext) + 1
   Resume
End Sub

Sub PeregruppirovkaV2()
   Dim sh As Sheets, ws As Worksheet, w As Worksheet, rn As Range, rw As Range
   Dim shName As String, rowsNum As Long, v As Variant, f As Boolean
   Dim dict As Object
'Áëîê ïîëó÷åíèÿ ññûëîê íà ïåðâè÷íûå äàííûå.
   Set sh = ActiveWorkbook.Worksheets
   On Error GoTo ErrNoData
      Set ws = sh("Äàííûå")
   On Error GoTo 0
   shName = ws.Range("A1")
   Set rn = ws.Range(ws.Range("A2"), ws.UsedRange.Cells(ws.UsedRange.Cells.Count))
   rowsNum = rn.Rows.Count + 1
'Áëîê ñîçäàíèÿ íîâîãî ëèñòà è ïåðåíîñà íà íåãî äàííûõ.
   Set ws = sh.Add(After:=sh(sh.Count))
'   Application.ScreenUpdating = False
   With ws
      rn.Copy .Range("B2")
'Áëîê âû÷ëåíåíèÿ ÔÈÎ è ïåðåíîñà èõ â ïåðâûé ñòîëáåö.
      For Each rn In .Range(.Range("B2"), .Cells(rowsNum, 2))
         If UBound(Split(rn)) > 0 Then 'Åñëè èìååòñÿ áîëüøå 1 ñëîâà...
            f = True
            For Each v In Split(rn)
               If Not (v Like "[À-ß]*") Then 'ïðîâåðÿåì, ÷òî âñå îíè çàãëàâíûå.
                  f = False   'Åñëè õîòÿ áû îäíî íå ñ çàãëàâíîé - ýòî íå ÔÈÎ.
                  Exit For
               End If
            Next v
            If f Then rn.Cut rn.Offset(, -1) ' ñëó÷àå óñïåõà - ÔÈÎ â 1 ñòîëáåö.
         End If
      Next rn
'Áëîê ðàçìíîæåíèÿ ÔÈÎ.
      For Each rn In .Range(.Range("A2"), .Cells(rowsNum, 1))
         If IsEmpty(rn) Then rn = rn.Offset(-1)
      Next rn
'Åùå íå ôèíàëüíûå øòðèõè...
      .Range("A1:D1") = Array("ÔÈÎ", "Êîä", "Íàèìåíîâàíèå", "Àäðåñ")
   End With
   On Error GoTo ErrNoData
      Set w = sh("Ñïèñîê")
   On Error GoTo 0
'Ñîçäàåì ñïèñîê ÔÈÎ äëÿ îáðàáîòêè.
   Set dict = CreateObject("Scripting.Dictionary")
   For Each rn In w.Range(w.Cells(1), w.Cells(w.Rows.Count, 1).End(xlUp))
      dict.Item(rn.Value) = 0
   Next rn
'Äëÿ êàæäîãî ÔÈÎ ïîëó÷àåì ññûëêó íà ñîîòâåòñòâóþùèé ëèñò (åñëè åãî íåò - ñîçäàåì).
'Çàïîëíÿåì ýòîò ëèñò äàííûìè èç àâòîôèëüòðà.
   For Each v In dict
      ws.Range("A1").AutoFilter 1, v
      With ws.AutoFilter.Range.SpecialCells(12)
         If .Areas.Count < 2 And .Rows.Count < 2 Then
            MsgBox "ÔÈÎ íå íàéäåíî: " & v & " - íåò â äàííûõ." & vbCrLf & _
            "Ïðîïóùåíî.", vbExclamation, "Ïðåäóïðåæäåíèå"
         Else
            f = True
            On Error GoTo ErrNoOutputSheet
               Set w = sh(Split(v)(0))
            On Error GoTo 0
            If f Then
               w.Cells.Clear
            Else
               Columns("A:A").ColumnWidth = 33.29
               Columns("B:B").ColumnWidth = 13.43
               Columns("B:B").NumberFormat = "m/d/yyyy"
               Columns("B:B").HorizontalAlignment = xlLeft
               Columns("C:C").ColumnWidth = 17.86
               Columns("D:D").ColumnWidth = 17.86
               Columns("F:F").NumberFormat = "0.0\%"
               Columns("G:G").NumberFormat = "0.0\%"
            End If
            f = True
            With ws.AutoFilter.Range
               For Each rw In .Rows(2).Resize(.Rows.Count - 1).SpecialCells(12).Rows
                  If f Then
                     Set rn = rw
                     f = False
                  Else
                     Set rn = Application.Union(rn, rw)
                  End If
               Next
            End With
            rn.Copy
            w.Range("A1").PasteSpecial xlPasteValues
         End If
      End With
   Next v
'À âîò òåïåðü ôèíèø!
   Application.DisplayAlerts = False
   ws.Delete
   Application.DisplayAlerts = True
   Application.CutCopyMode = False
   Application.ScreenUpdating = True
   Exit Sub
ErrNoData:
   MsgBox "Íå ìîãó íàéòè ëèñò ""Äàííûå"" èëè ""Ñïèñîê"".", vbExclamation, "Îøèáêà"
   Exit Sub
ErrNoOutputSheet:
   f = False
   Set w = sh.Add(After:=sh(sh.Count))
   w.Name = Split(v)(0)
   Resume Next
End Sub