For what it's worth, this is the best I can do. The following macro creates a new document with the content of the pages of the original document sorted according to the last word in the second paragraph.
Code: Select all
Sub SortPages()
Dim arrPages
Dim n As Long
Dim m As Long
Dim i As Long
Dim j As Long
Dim rng As Range
Dim par As Paragraph
Dim wrd As Range
Dim txt As String
Dim arr()
Dim s As String
Dim doc As Document
m = Selection.Information(wdNumberOfPagesInDocument)
Selection.HomeKey Unit:=wdStory
Do
n = n + 1
ReDim Preserve arr(1 To 3, 1 To n)
Set rng = ActiveDocument.Bookmarks("\page").Range
Set par = rng.Paragraphs(2)
Set wrd = par.Range
wrd.Collapse Direction:=wdCollapseEnd
wrd.MoveStart Unit:=wdWord, Count:=-2
wrd.MoveEnd Unit:=wdWord, Count:=-1
txt = wrd.Text
arr(1, n) = n
Set arr(2, n) = rng
arr(3, n) = txt
Selection.GoToNext wdGoToPage
Loop Until n = m
For i = 1 To m - 1
For j = i + 1 To m
If arr(3, j) < arr(3, i) Then
n = arr(1, i)
arr(1, i) = arr(1, j)
arr(1, j) = n
s = arr(3, i)
arr(3, i) = arr(3, j)
arr(3, j) = s
End If
Next j
Next i
Set doc = Documents.Add
For i = 1 To m
arr(2, arr(1, i)).Copy
Set wrd = doc.Content
wrd.Collapse Direction:=wdCollapseEnd
wrd.Paste
Next i
End Sub
If there is a period (or exclamation mark or question mark) after the last word in the second paragraph, change
Code: Select all
wrd.MoveStart Unit:=wdWord, Count:=-2
wrd.MoveEnd Unit:=wdWord, Count:=-1
to
Code: Select all
wrd.MoveStart Unit:=wdWord, Count:=-3
wrd.MoveEnd Unit:=wdWord, Count:=-2