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

'Макрос получает данные с определенного листа и производит их
'перегруппировку по листам рабочей книги таким образом, чтобы
'один лист соответствовал одному ФИО из списка треубемых.
Sub PeregruppirovkaV3()
 
'________________________________________________________________
'______________________Параметры окружения_______________________
 
Const DATASHEET = "Данные"  'Лист с данными.
Const DESTRANGE = "A410"    'Верхняя левая ячейка диапазона вывода
                            'обработанных данных.
Const LISTSHEET = "Список"  'Лист со списком требуемых ФИО.
Const LISTRANGE = "D1:D20"  'Диапазон, в котором находится список
                            'требуемых ФИО.
'________________________________________________________________
'________________________________________________________________
 
    Dim wsData As Worksheet, wsList As Worksheet, ws As Worksheet
    Dim rn As Range, coll As Collection
    Dim dict As Object, dsh As Object
    Dim arrData() As Variant, arrList() As Variant
    Dim arr() As Variant, dkeys() As Variant, narr() As Long
    Dim i As Long, j As Long, n As Long, m As Long
    Dim k As Long, u As Long, w As Long, l As Long, q As Long
    Dim v As Variant, s As String, z As String, f As Boolean
    'Получаем ссылки на листы с данными и списком.
    On Error GoTo ErrNoData
        s = DATASHEET
        Set wsData = Sheets(DATASHEET)
        s = LISTSHEET
        Set wsList = Sheets(LISTSHEET)
    On Error GoTo 0
    'Получаем массив данных и список требуемых ФИО.
    arrData = wsData.UsedRange
    arrList = wsList.Range(LISTRANGE)
    n = UBound(arrData)
    m = UBound(arrData, 2)
    ReDim arr(m - 1) As Variant
    'Получаем ФИО из списка.
    Set dict = CreateObject("Scripting.Dictionary")
    For Each v In arrList
        s = v
        If IsFIO(s) And Not dict.Exists(s) Then
            Set coll = New Collection
            dict.Add s, coll
        End If
    Next v
    k = dict.Count
    If k Then 'Если список не пуст, то...
        'Для каждого ФИО находим соответствующие данные.
        While i < n
            i = i + 1
            s = arrData(i, 1)
            If f Then
                If IsFIO(s) Then
                    f = False
                Else
                    For j = 1 To m
                        arr(j - 1) = arrData(i, j)
                    Next j
                    coll.Add arr
                    ReDim arr(m - 1) As Variant
                End If
            End If
            If Not f Then
                If dict.Exists(s) Then
                    f = True
                    For j = 2 To m
                        arr(j - 1) = arrData(i, j)
                    Next j
                    Set coll = dict(s)
                    coll.Add arr
                    ReDim arr(m - 1) As Variant
                End If
            End If
        Wend
        'Создаем сокращенные ФИО для названий листов.
        Set dsh = CreateObject("Scripting.Dictionary")
        If k > 1 Then
            ReDim arr(k - 1) As Variant
            ReDim narr(k - 1) As Long
            For i = 0 To k - 1
                dkeys = dict.Keys
                arr(i) = Split(dkeys(i))
                u = UBound(arr(i))
                If u > w Then w = u
            Next i
            For i = 0 To w - 1
                For j = 0 To k - 1
                    s = arr(j)(0)
                    If i > 0 Then
                        On Error Resume Next
                            For l = 1 To i
                                s = s & "_" & Left(arr(j)(l), 1)
                            Next l
                        On Error GoTo 0
                    End If
                    For q = 0 To k - 1
                        If q <> j Then
                            z = arr(q)(0)
                            If i > 0 Then
                                On Error Resume Next
                                    For l = 1 To i
                                        z = z & "_" & Left(arr(q)(l), 1)
                                    Next l
                                On Error GoTo 0
                            End If
                            If s = z Then
                                narr(j) = i + 1
                                Exit For
                            End If
                        End If
                    Next q
                Next j
            Next i
            For i = 0 To k - 1
                s = arr(i)(0)
                If narr(i) > 0 Then
                    On Error Resume Next
                        For l = 1 To narr(i)
                            s = s & "_" & Left(arr(i)(l), 1)
                        Next l
                    On Error GoTo 0
                End If
                dkeys = dict.Keys
                dsh.Add dkeys(i), s
            Next i
        Else
            dkeys = dict.Keys
            s = dkeys(0)
            dsh.Add s, Split(s)(0)
        End If
    End If
    'Получаем ссылку на лист выходных данных или создаем его.
    'Выгружаем данные из коллекции в массив, а затем на лист.
    For Each v In dict
        If dict(v).Count > 0 Then
            f = True
            s = dsh(v)
            On Error GoTo ErrNoOutputSheet
                Set ws = Sheets(s)
            On Error GoTo 0
            Set rn = ws.Range(DESTRANGE)
            If f Then
                rn.Resize(ws.Rows.Count - rn.Row + 1, m + 1).ClearContents
            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
            Erase arr
            n = dict(v).Count
            ReDim arr(n - 1, m - 1) As Variant
            For i = 0 To n - 1
                For j = 0 To m - 1
                    arr(i, j) = dict(v)(i + 1)(j)
                Next j
            Next i
            rn.Resize(n) = v
            rn.Offset(, 1).Resize(n, m) = arr
        End If
    Next v
    Exit Sub
 
ErrNoData:
    MsgBox "Лист " & s & " не найден.", vbExclamation, "Ошибка"
    Exit Sub
 
ErrNoOutputSheet:
    f = False
    With Sheets
        Set ws = .Add(After:=.Item(.Count))
    End With
    ws.Name = s
    Resume Next
 
End Sub
 
'Функция проверяет входную строку s и возвращает True, если
'входная строка соответствует шаблону ФИО.
Function IsFIO(ByVal s As String) As Boolean
    With CreateObject("VBScript.RegExp")
        .Pattern = "^[А-ЯЁ][а-яё]*( [А-ЯЁ][а-яё]*)+$"
        IsFIO = .Test(s)
    End With
End Function