VBA to cut and paste pages by criteria and sort

Awkword
Lounger
Posts: 36
Joined: 30 Oct 2012, 04:49
Location: Eventually, Nowhere

VBA to cut and paste pages by criteria and sort

Post by Awkword »

I ran into another VBA challenge: What would be the most efficient way to cut and paste pages within a document so that they are sorted in order?
My example is this...each name represents a page of text within a document:
  • Abbott
    Abbott
    Abbott
    Costello
    Costello
    Costello
    Costello
    Abbott
    Costello
    Costello
    Abbott
I want to leave the "Costello" pages in their current order but I am trying to create code that will Find the "Abbott" pages and cut and paste them to the top of the document in the same order as they appear.

Thanks in advance for any help!

And just in case you're unfamiliar with Abbott and Costello here's a clip http://www.youtube.com/watch?v=k37HOam7 ... re=related
There's no place like 127.0.0.1

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: VBA to cut and paste pages by criteria and sort

Post by HansV »

Should the pages be sorted by the first word on the page?
Best wishes,
Hans

Awkword
Lounger
Posts: 36
Joined: 30 Oct 2012, 04:49
Location: Eventually, Nowhere

Re: VBA to cut and paste pages by criteria and sort

Post by Awkword »

Hans I think I've learned enough VBA to write code that will number (temporarily) each page with the word "Abbott" on it like Abbott1, Abbott2, etc. However, I'm uncertain of how to then get get the document sorted from this order:

Abbott1
Abbott2
Abbott3
Costello1
Costello2
Costello3
Costello4
Abbott4
Costello5
Costello6
Abbott5

to this order:

Abbott1
Abbott2
Abbott3
Abbott4
Abbott5
Costello1
Costello2
Costello3
Costello4
Costello5
Costello6
There's no place like 127.0.0.1

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: VBA to cut and paste pages by criteria and sort

Post by HansV »

OK, but will that word be the first word on the page, or will it be in the header or footer, or ...?
Best wishes,
Hans

Awkword
Lounger
Posts: 36
Joined: 30 Oct 2012, 04:49
Location: Eventually, Nowhere

Re: VBA to cut and paste pages by criteria and sort

Post by Awkword »

In this case the word "Abbott" will reside in the second paragraph of each "Abbott" page.
There's no place like 127.0.0.1

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: VBA to cut and paste pages by criteria and sort

Post by HansV »

Sorry about all the questions - a "page" is not a natural concept in Word, so this is not as simple as it may seem.

Will the word "Abbot" or "Costello" etc. be the only word in the second paragraph?
If not, will it be the first word in the second paragraph, or will it be in between other words in that paragraph?

Is there a page break at the end of every page, or do you rely on Word's automatic pagination?
Best wishes,
Hans

Awkword
Lounger
Posts: 36
Joined: 30 Oct 2012, 04:49
Location: Eventually, Nowhere

Re: VBA to cut and paste pages by criteria and sort

Post by Awkword »

Hans your diligence is greatly appreciated as all of these concepts in Word are new to me. Excel VBA is my strong suit.

1)"Abbot" will be the last word in the second paragraph. Having said that, would it be more advantageous to do a string search within the 2nd paragraph?

2) Currently I am relying on Word's automatic pagination and the document is currently at 151 "pages" in Print Layout view. Your comments are making wonder if a page number field will be required...?
There's no place like 127.0.0.1

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: VBA to cut and paste pages by criteria and sort

Post by HansV »

If you rely on automatic pagination, it's quite likely that moving pages around will cause page boundaries to shift - text that used to be on one page might end up on two pages, or the other way round.

Perhaps we should approach this differently: how is this document created? Would it be possible to create the document in the correct order?
Best wishes,
Hans

Awkword
Lounger
Posts: 36
Joined: 30 Oct 2012, 04:49
Location: Eventually, Nowhere

Re: VBA to cut and paste pages by criteria and sort

Post by Awkword »

In this case, I have no control over the creation of the document.
There's no place like 127.0.0.1

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: VBA to cut and paste pages by criteria and sort

Post by HansV »

I don't see an easy solution yet, but I'll look at it again tomorrow.
Best wishes,
Hans

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: VBA to cut and paste pages by criteria and sort

Post by HansV »

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
Best wishes,
Hans

Awkword
Lounger
Posts: 36
Joined: 30 Oct 2012, 04:49
Location: Eventually, Nowhere

Re: VBA to cut and paste pages by criteria and sort

Post by Awkword »

Hans - many many thanks for your time! So glad I stumbled into your lounge. :cheers:

When I applied the above code it created more issues within the document but I will study it and (hopefully) slight modifications will resolve the issue.
There's no place like 127.0.0.1

User avatar
macropod
4StarLounger
Posts: 508
Joined: 17 Dec 2010, 03:14

Re: VBA to cut and paste pages by criteria and sort

Post by macropod »

For a completely different approach:

Code: Select all

Sub Sort()
Application.ScreenUpdating = False
Dim i As Long, j As Long, Rng As Range, Tbl As Table
j = ActiveDocument.ComputeStatistics(wdStatisticPages)
With ActiveDocument
  .Range.InsertAfter vbCr & Chr(12)
  .Repaginate
  Set Tbl = .Tables.Add(Range:=.Characters.Last, NumRows:=j, NumColumns:=1)
  For i = j 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
    Rng.Cut
    Tbl.Range.Cells(i).Range.Paste
  Next
  Set Rng = .Range(0, Tbl.Range.Start)
  Rng.Text = vbNullString
  With Tbl
    .Rows.AllowBreakAcrossPages = False
    .LeftPadding = 0
    .RightPadding = 0
    .SortAscending
  End With
End With
Application.ScreenUpdating = True
End Sub
Paul Edstein
[Fmr MS MVP - Word]

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: VBA to cut and paste pages by criteria and sort

Post by HansV »

Hi Paul, I like the idea of using a table, but how can you ensure that the table is sorted on the last word of the second paragraph in each cell (=page)?
Best wishes,
Hans

User avatar
macropod
4StarLounger
Posts: 508
Joined: 17 Dec 2010, 03:14

Re: VBA to cut and paste pages by criteria and sort

Post by macropod »

Hi Hans,

I hadn't read the later posts referring to the last word of the second paragraph, but that shouldn't be too difficult to accommodate - simply replicate that word at the start of the cell before sorting, then delete it afterwards. For example (untested):

Code: Select all

Sub Sort()
Application.ScreenUpdating = False
Dim i As Long, j As Long, Rng As Range, Tbl As Table
j = ActiveDocument.ComputeStatistics(wdStatisticPages)
With ActiveDocument
  .Range.InsertAfter vbCr & Chr(12)
  .Repaginate
  Set Tbl = .Tables.Add(Range:=.Characters.Last, NumRows:=j, NumColumns:=1)
  For i = j 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
    Rng.Cut
    With Tbl.Range.Cells(i).Range
      .Paste
      .Words.First.InsertBefore .Paragraphs(2).Range.Words.Last & vbCr
    End With
  Next
  Set Rng = .Range(0, Tbl.Range.Start)
  Rng.Text = vbNullString
  With Tbl
    .LeftPadding = 0
    .RightPadding = 0
    .SortAscending
    For i = 1 To j
      .Range.Cells(i).Range.Paragraphs.First.Range.Text = vbNullString
    Next
    .Rows.AllowBreakAcrossPages = False
  End With
End With
Application.ScreenUpdating = True
End Sub
Paul Edstein
[Fmr MS MVP - Word]

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: VBA to cut and paste pages by criteria and sort

Post by HansV »

Thanks, Paul. With a little modification, that should work. VBA sees the paragraph mark as the last word in the paragraph, and the period at the end of a sentence as the next to last word, so

Code: Select all

      .Words.First.InsertBefore .Paragraphs(2).Range.Words.Last.Previous(wdWord, 2) & vbCr
should extract the "logical" last word.
Best wishes,
Hans

User avatar
macropod
4StarLounger
Posts: 508
Joined: 17 Dec 2010, 03:14

Re: VBA to cut and paste pages by criteria and sort

Post by macropod »

Hi Hans,

You're welcome.

FWIW, if you want to keep the 'Abbots' in the same order as they start in, and the Costellos likewise, simply insert ' i & ' [or perhaps ' Format(i, "000") & '] before the vbCr.
Paul Edstein
[Fmr MS MVP - Word]

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: VBA to cut and paste pages by criteria and sort

Post by HansV »

Hi Paul,

SortAscending assumes that the first row of the table is a header row, so we have to use Sort instead of SortAscending.

The following version of your macro appears to work correctly:

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
        ' .SortAscending - commented out since it excludes the top row
        For i = 1 To n
            .Range.Cells(i).Range.Paragraphs.First.Range.Text = vbNullString
        Next i
        .Rows.AllowBreakAcrossPages = False
    End With
    Application.ScreenUpdating = True
End Sub
If desired, you can add

Code: Select all

        .ConvertToText
above the last End With (but that will probably mess with the pagination).
Last edited by HansV on 05 Nov 2012, 21:38, edited 1 time in total.
Reason: to correct oversight (thanks macropod!)
Best wishes,
Hans

User avatar
macropod
4StarLounger
Posts: 508
Joined: 17 Dec 2010, 03:14

Re: VBA to cut and paste pages by criteria and sort

Post by macropod »

But you still have .SortAscending!!
Paul Edstein
[Fmr MS MVP - Word]

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: VBA to cut and paste pages by criteria and sort

Post by HansV »

Yikes! I should have removed that line - thanks for pointing out my oversight.
Best wishes,
Hans