VBA to cut and paste pages by criteria and sort

[Awkword]

Got some catching up to do here...I'll see what the results are with this method asap.

[Awkword]

Gentlemen - this is absolutely fantastic! Perfectly resolved my issue. I don't fully understand all of the code but will spend more time dissecting it. The .converttotext also worked flawlessly.

For future readers, the final code I used was:

Code: Select all

Sub Sort()

    Dim i As Long, n As Long, rng As Range, tbl As Table
    Application.ScreenUpdating = False
    n = ActiveDocument.ComputeStatistics(wdStatisticPages)
    With ActiveDocument
        .Range.InsertAfter vbCr & Chr(12)
        .Repaginate
        Set tbl = .Tables.Add(Range:=.Characters.Last, _
            NumRows:=n, NumColumns:=1)
        For i = n To 1 Step -1
            Set rng = .GoTo(What:=wdGoToPage, Name:=i)
            Set rng = rng.GoTo(What:=wdGoToBookmark, Name:="\page")
            If rng.Characters.Last.Previous = Chr(12) Then
                rng.End = rng.End - 2
            End If
            rng.Cut
            With tbl.Range.Cells(i).Range
                .Paste
                .Words.First.InsertBefore .Paragraphs(2).Range.Words _
                    .Last.Previous(wdWord, 2) & Format(i, "000") & vbCr
            End With
        Next i
        Set rng = .Range(0, tbl.Range.Start)
    End With
    rng.Text = vbNullString
    With tbl
        .LeftPadding = 0
        .RightPadding = 0
        .Sort ExcludeHeader:=False, FieldNumber:=1, _
            SortFieldType:=wdSortFieldAlphanumeric, _
            SortOrder:=wdSortOrderAscending, CaseSensitive:=False
        For i = 1 To n
            .Range.Cells(i).Range.Paragraphs.First.Range.Text = vbNullString
        Next i
        .Rows.AllowBreakAcrossPages = False
        .ConvertToText
    End With
    Application.ScreenUpdating = True
End Sub

[macropod]

Glad it worked. Just goes to show that thinking outside the box - in this case turning the paradigm upside down and thinking inside a table - can produce the results.