Сортировка страниц в word

Option Explicit
Public Type Tbl
    Start As Long
    Sum As Single
End Type
Public Sub SortTables()
    Dim ar() As Tbl, oNewDoc As Document, oCurrDoc As Document
    Dim t As Tbl
    ReDim ar(0)
    Set oCurrDoc = ActiveDocument
    With oCurrDoc.Range.Find
        .Text = "<[0-9]@-[0-9]{2}>"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        While .Execute
            t.Start = .Parent.Tables(1).Range.Start
            t.Sum = CSng(Replace(.Parent.Text, "-", ","))
            ar(UBound(ar)) = t
            ReDim Preserve ar(UBound(ar) + 1)
        Wend
    End With
    ReDim Preserve ar(UBound(ar) - 1)
    Dim i As Long, j As Long, temp As Tbl
    For i = 0 To UBound(ar) - 1
        For j = i + 1 To UBound(ar)
            If ar(i).Sum > ar(j).Sum Then
                temp = ar(i)
                ar(i) = ar(j)
                ar(j) = temp
            End If
    Next j, i
    Set oNewDoc = Documents.Add
    Dim oRng As Range
    For i = 0 To UBound(ar)
        oCurrDoc.Range(ar(i).Start, ar(i).Start).Tables(1).Range.Copy
        oNewDoc.Paragraphs.Last.Range.PasteAndFormat (wdFormatOriginalFormatting)
        If i < UBound(ar) Then oNewDoc.Paragraphs.Last.Range.InsertBreak wdPageBreak
    Next i
End Sub

Public Type Tbl
    Start As Long
    Sum As Single
End Type

Public Sub SortTables()
    Dim ar() As Tbl, oNewDoc As Document, oCurrDoc As Document
    Dim t As Tbl
    ReDim ar(0)
    Set oCurrDoc = ActiveDocument
    With oCurrDoc.Range.Find
        .Text = "<[0-9]@-[0-9]{2}>"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        While .Execute
            .Parent.Select
            If Len(.Parent.Cells(1).Range.Text) = Len(.Parent.Text) + 2 Then
                t.Start = .Parent.Start
                t.Sum = CSng(Replace(.Parent.Text, "-", ","))
                ar(UBound(ar)) = t
                ReDim Preserve ar(UBound(ar) + 1)
            End If
        Wend
    End With
    ReDim Preserve ar(UBound(ar) - 1)
    
    Dim i As Long, j As Long, temp As Tbl
    For i = 0 To UBound(ar) - 1
        For j = i + 1 To UBound(ar)
            If ar(i).Sum > ar(j).Sum Then
                temp = ar(i)
                ar(i) = ar(j)
                ar(j) = temp
            End If
    Next j, i
    
    Set oNewDoc = Documents.Add
    For i = 0 To UBound(ar)
        oCurrDoc.Range(ar(i).Start, ar(i).Start).Tables(1).Range.Copy
        oNewDoc.Paragraphs.Last.Range.PasteAndFormat (wdFormatOriginalFormatting)
        If i < UBound(ar) Then oNewDoc.Paragraphs.Last.Range.InsertBreak wdPageBreak
        DoEvents
        StatusBar = "Обработано " & i & " таблиц из " & UBound(ar)
    Next i
End Sub