Как пересортировать страницы документа по ФИО в алфавитном порядке из конкретной строки на странице?

Sub p2()
'
 
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "^m"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
    Selection.Cut
    Documents.Add DocumentType:=wdNewBlankDocument
    With Selection.PageSetup
        .LineNumbering.Active = False
        .Orientation = wdOrientPortrait
        .TopMargin = CentimetersToPoints(1.27)
        .BottomMargin = CentimetersToPoints(2)
        .LeftMargin = CentimetersToPoints(1.59)
        .RightMargin = CentimetersToPoints(1.5)
        .Gutter = CentimetersToPoints(0)
        .HeaderDistance = CentimetersToPoints(1.25)
        .FooterDistance = CentimetersToPoints(1.25)
        .PageWidth = CentimetersToPoints(21)
        .PageHeight = CentimetersToPoints(29.7)
        .FirstPageTray = wdPrinterDefaultBin
        .OtherPagesTray = wdPrinterDefaultBin
        .SectionStart = wdSectionNewPage
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .VerticalAlignment = wdAlignVerticalTop
        .SuppressEndnotes = False
        .MirrorMargins = False
        .TwoPagesOnOne = False
        .BookFoldPrinting = False
        .BookFoldRevPrinting = False
        .BookFoldPrintingSheets = 1
        .GutterPos = wdGutterPosLeft
    End With
    Selection.PasteAndFormat (wdFormatOriginalFormatting)
    Selection.TypeBackspace
    Selection.WholeStory
    'Selection.ParagraphFormat.LineSpacing ' =  'LinesToPoints(32948)
    Selection.HomeKey Unit:=wdStory
     Selection.MoveDown Unit:=wdLine, Count:=11
    Selection.HomeKey Unit:=wdLine
    Selection.EndKey Unit:=wdLine, Extend:=wdExtend
    Selection.MoveLeft Unit:=wdCharacter, Count:=4, Extend:=wdExtend
    Selection.Copy
    Name1 = Selection
    Selection.HomeKey Unit:=wdLine
    Selection.MoveUp Unit:=wdLine, Count:=2
    Selection.EndKey Unit:=wdLine, Extend:=wdExtend
    Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    Selection.Copy
    Name2 = Selection
    Name3 = ActiveDocument.Name
    ChangeFileOpenDirectory "G:\WORK\WORKIT\20180708"
    ActiveDocument.SaveAs2 FileName:=Name1 + "_" + Name2 + Name3 + ".doc", _
        FileFormat:=wdFormatDocument, LockComments:=False, Password:="", _
        AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
        EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
        :=False, SaveAsAOCELetter:=False, CompatibilityMode:=0
    ActiveWindow.Close
    
End Sub

Sub SortPages()
Dim t As Document, r As Range, n&, i&, s$, p&(0 To 32767), d$(0 To 32767), cl As New Collection
  Set t = ActiveDocument
  t.Range(t.Range.End - 1).InsertBefore Chr(12)       'добавить разрыв страницы в конце
  Set r = t.Range(0, 0)
  With r.Find
    .ClearFormatting
    .Text = "^m"
    .Forward = True
    .Wrap = wdFindStop
  End With
  Do
    p(n) = r.End                                      'начало очередной страницы
    If r.Move(wdParagraph, 11) < 11 Then Exit Do      'к 12-му абзацу страницы
    d(n) = r.Paragraphs(1).Range.Text                 'фамилия очередной страницы
    For i = 1 To cl.Count                             'простейшая сортировка на коллекции
      If d(n) < d(cl(i)) Then cl.Add n, , i: GoTo 1
    Next
    cl.Add n
1   n = n + 1
  Loop Until Not r.Find.Execute
  With Documents.Add
    For i = 1 To cl.Count
      t.Range(p(cl(i)), p(cl(i) + 1)).Copy            'скопировать диапазон очередной стриницы
      .Range(.Range.End - 1).Paste                    'вставить в конец нового документа
    Next
    .Range(.Range.End - 2).Delete                     'удалить разрыв страницы в конце
  End With
  t.Range(t.Range.End - 2).Delete
End Sub