Page 1 of 2 12 LastLast
Results 1 to 15 of 20
  1. #1
    New Lounger
    Join Date
    Dec 2011
    Location
    Central Florida, USA
    Posts
    9
    Thanks
    2
    Thanked 0 Times in 0 Posts

    Find, Copy Page, Paste to New, Loop

    I am trying to write a Macro that will find a specific string of TXT, copy the page(s) that the TXT is on, Paste the page(s) to another/new document, and loop through the end of the "Main" document. Below is what I have so far and it works...somewhat. The problems are that is misses the first instance of the search word, but eventually finds it and includes it, but also gives me multiple copies and loops continuosly to where I have to "break" it. Any input is appreciated. Thank you.

    Code:
    Sub TestCopier()
    Dim rngStory As Range
    Dim sWord As String
    Set MainDoc = ActiveDocument
    sWord = InputBox("Enter term to find", "Print pages")
    Documents.Add DocumentType:=wdNewBlankDocument
    ActiveDocument.SaveAs FileName:=sWord & ".doc"
    MainDoc.Activate
    With Selection.Find
      Do While .Execute(findText:=sWord)
        Application.Browser.Next
        Selection.GoTo What:=wdGoToBookmark, Name:="\page"
        Selection.Copy
        ActiveWindow.Next.Activate
        Selection.InsertAfter (sBigString)
        Selection.PasteAndFormat (wdPasteDefault)
        MainDoc.Activate
      Loop
    End With
    End Sub
    Last edited by macropod; 2011-12-06 at 19:49. Reason: Added code tags

  2. #2
    Super Moderator
    Join Date
    Dec 2000
    Location
    New York, NY
    Posts
    2,970
    Thanks
    3
    Thanked 29 Times in 27 Posts
    Welcome to the Lounge!

    Without taking the time to try out the code right now, here are a couple of quick suggestions:

    Similiar to how you're setting a reference ("MainDoc") to the ActiveDocument, you should also set a reference to the new document:

    Set NewDoc = Documents.Add(DocumentType:=wdNewBlankDocument)

    - and then use that reference later ("NewDoc.Activate", rather than "ActiveWindow.Next.Activate") to move to the new document - that's always best when shuttling between two documents.

    Other suggestion is that when you do the "MainDoc.Activate" from within the loop, it's probably returning the selection point to the start of the MainDoc each time - that could account for why you're getting multiple copies, and why you get stuck in a loop.
    You might need to find a way (like setting a temporary bookmark at the location of the previous Find, and then return to the next character after that bookmark, when you return to Main Doc) - that way the Find would resume where it left off.

    Couple more comments/questions:
    - What is "sBigString" - doesn't look like a value is getting assigned to that string, prior to it being used to insert text.
    - Best to use 'Option Explicit' at the top of your code module - that will force you to declare all variables (which is a good thing).

    Gary

  3. #3
    New Lounger
    Join Date
    Dec 2011
    Location
    Central Florida, USA
    Posts
    9
    Thanks
    2
    Thanked 0 Times in 0 Posts
    Excellent, I got it to work...somewhat. My only issue is the for some reason, even after starting the routine on the first page everytime, the first instance of the search return puts ends up on the last page of the new document. When I step through it find the second instance first. Confused but and awesome result after fightinf this for an entire day. Thanks!
    Last edited by Snowshoeken; 2011-12-07 at 09:48. Reason: Got it to work

  4. #4
    Super Moderator
    Join Date
    Dec 2000
    Location
    New York, NY
    Posts
    2,970
    Thanks
    3
    Thanked 29 Times in 27 Posts
    Glad if that's working better. One thing I have to correct from my earlier post: changing which document is activated, does take you back to the current insertion point/selection in that document, not to the start of the document - so that part alone wouldn't cause a problem - although if it takes you back to MainDoc with the current found string still selected, you'd want to do something like a "Selection.Collapse wdCollapseEnd" so that the Find will resume after that already-found string.

    If you want to repost the code as you've currently got it, maybe we can iron out the remaining problems.

    Gary

  5. #5
    New Lounger
    Join Date
    Dec 2011
    Location
    Central Florida, USA
    Posts
    9
    Thanks
    2
    Thanked 0 Times in 0 Posts
    Hmmm. Honestly the issue of the first page ending up at the end is ok as the next step is to convert it to .PDF. At which point I can easily move the page back to the beginning. Here is the code as it stands.

    Code:
    Sub TestCopier()
    Dim rngStory As Range
    Dim sWord As String
    Set MainDoc = ActiveDocument
         
    sWord = InputBox("Enter term to find", "Print pages")
      
    Set NewDoc = Documents.Add(DocumentType:=wdNewBlankDocument)
    ActiveDocument.SaveAs FileName:=sWord & ".doc"
    Selection.GoTo What:=wdGoToPage, Which:=lNextPage
    MainDoc.Activate
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:="1"
    On Error Resume Next
    ActiveDocument.Bookmarks("TMXFound").Delete
      
    With Selection.Find
      Do While .Execute(findText:=sWord)
      
        With ActiveDocument.Bookmarks
          .Add Range:=Selection.Range, Name:="TMXFound"
          .DefaultSorting = wdSortByName
          .ShowHidden = False
        End With
        
        Application.Browser.Next
        Selection.GoTo What:=wdGoToBookmark, Name:="\page"
    
        Selection.Copy
    
        NewDoc.Activate
        Selection.GoTo What:=wdGoToPage, Which:=lNextPage
        Selection.PasteAndFormat (wdPasteDefault)
    
        MainDoc.Activate
        Selection.GoTo What:=wdGoToBookmark, Name:="TMXFound"
      Loop
    End With
    End Sub
    Last edited by macropod; 2011-12-07 at 20:02. Reason: Added code tags - again!

  6. #6
    Super Moderator
    Join Date
    May 2002
    Location
    Canberra, Australian Capital Territory, Australia
    Posts
    5,054
    Thanks
    2
    Thanked 417 Times in 346 Posts
    Hi snowshoeken,

    Try something along the lines of:
    Code:
    Sub TestCopier()
    ' Store current Track Changes status, then switch off
    Dim TrkStatus As Boolean      ' Track Changes flag
    With ActiveDocument
      TrkStatus = .TrackRevisions
      .TrackRevisions = False
    End With
    ' Turn Off Screen Updating
    Application.ScreenUpdating = False
    ' Document-related variables
    Dim DocIn As Document, DocOut As Document, i As Long
    Dim RngIn As Range, RngOut As Range, StrFnd As String
    ' Solicit the string to find
    StrFnd = InputBox("Enter term to find", "Print pages")
    ' Exit if there's no valid input
    If Trim(StrFnd) = "" Then
      MsgBox "Nothing to find", vbExclamation
      Exit Sub
    End If
    ' Define the input document
    Set DocIn = ActiveDocument
    ' Create and define the output document
    Set DocOut = Documents.Add(DocumentType:=wdNewBlankDocument)
    ' Process the input document
    With DocIn.Range
      With .Find
        .ClearFormatting
        .Text = StrFnd
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute
      End With
      Do While .Find.Found
        ' Keep a count
        i = i + 1
        ' Obtain the found page
        Set RngIn = .Paragraphs(1).Range
        Set RngIn = RngIn.GoTo(What:=wdGoToBookmark, Name:="\page")
        ' Copy the found page
        RngIn.Copy
        ' Get the end of the output document
        Set RngOut = DocOut.Range.Characters.Last
        ' Paste the found page into the output document and add a page break
        With RngOut
          .PasteAndFormat (wdPasteDefault)
          If RngIn.Characters.Last < Chr(12) Or RngIn.Characters.Last > Chr(14) Then .InsertAfter Chr(12)
        End With
        ' Move the find start to the end of the current page
        ' This avoids multiple finds on the same page
        .Start = RngIn.End
        ' Do another Find
        .Find.Execute
      Loop
    End With
    With DocOut
      ' Delete everything after the last paragraph with text
      While .Characters.Last.Previous.Text < Chr(32)
        .Characters.Last.Previous.Delete
      Wend
      ' Save
      .SaveAs FileName:=StrFnd, Fileformat:=wdFormatDocument
    End With
    Set DocIn = Nothing: Set DocOut = Nothing
    ' Restore original Track Changes status
    ActiveDocument.TrackRevisions = TrkStatus
    ' Restore Screen Updating
    Application.ScreenUpdating = True
    ' Inform the user
    MsgBox i & " pages found & copied."
    End Sub
    PS: When posting code, please use code tags.
    Last edited by macropod; 2011-12-08 at 01:18. Reason: Code enhancements, for saving & output doc cleanup
    Cheers,

    Paul Edstein
    [MS MVP - Word]

  7. #7
    Super Moderator
    Join Date
    Dec 2000
    Location
    New York, NY
    Posts
    2,970
    Thanks
    3
    Thanked 29 Times in 27 Posts
    Looks like you've now got two solutions to try! ;-)
    For what it's worth, here's another version:

    Code:
    Sub TestCopier2()
    Dim rngStory As Range
    Dim sWord As String
    Dim MainDoc As Document
    Dim NewDoc As Document
    Dim fNewDocCreated As Boolean
    
    Application.ScreenUpdating = False
    
    Set MainDoc = ActiveDocument
    Selection.HomeKey Unit:=wdStory
    
    sWord = InputBox("Enter term to find", "Print pages")
      
    With Selection.Find
      Do Until .Execute(findText:=sWord) = False
      
       If fNewDocCreated = False Then
          Set NewDoc = Documents.Add(DocumentType:=wdNewBlankDocument)
          NewDoc.SaveAs FileName:=sWord & ".doc"
          fNewDocCreated = True
          MainDoc.Activate
          Selection.Collapse wdCollapseEnd
       End If
    
        Selection.GoTo What:=wdGoToBookmark, Name:="\page"
    
        Selection.Copy
    
        NewDoc.Activate
        Selection.EndKey Unit:=wdStory
        Selection.PasteAndFormat (wdPasteDefault)
    
        MainDoc.Activate
        Selection.Collapse wdCollapseEnd
      Loop
    End With
    
    Set MainDoc = Nothing
    Set NewDoc = Nothing
    Application.ScreenUpdating = True
    End Sub
    Gary

  8. The Following User Says Thank You to Gary Frieder For This Useful Post:

    Snowshoeken (2011-12-08)

  9. #8
    Super Moderator
    Join Date
    May 2002
    Location
    Canberra, Australian Capital Territory, Australia
    Posts
    5,054
    Thanks
    2
    Thanked 417 Times in 346 Posts
    Hi Gary,

    Using Selection:
    • is much less efficient than using ranges (which is why I used only ranges);
    • can cause lots of screen flicker; and
    • potentially leaves the selection in the source document anywhere but where it started out at.

    Note also that I've saved the new document after completing it, rather than before.
    Cheers,

    Paul Edstein
    [MS MVP - Word]

  10. The Following User Says Thank You to macropod For This Useful Post:

    Snowshoeken (2011-12-08)

  11. #9
    New Lounger
    Join Date
    Dec 2011
    Location
    Central Florida, USA
    Posts
    9
    Thanks
    2
    Thanked 0 Times in 0 Posts
    My cup runeth over! Thanks, I will give them a try. Now, if you all have any thoughts on this proceedure running through the plethera of footers that can be in a document, that would be spot on. Also, before I post any code again. Thank you gain.
    Last edited by Snowshoeken; 2011-12-08 at 11:26.

  12. #10
    New Lounger
    Join Date
    Dec 2011
    Location
    Central Florida, USA
    Posts
    9
    Thanks
    2
    Thanked 0 Times in 0 Posts
    Tried and true, both work spot on. Many Thanks!

  13. #11
    Super Moderator
    Join Date
    May 2002
    Location
    Canberra, Australian Capital Territory, Australia
    Posts
    5,054
    Thanks
    2
    Thanked 417 Times in 346 Posts
    Hi snowshoeken,

    To use code tags, you can either:
    click on the 'Go Advanced' button below the 'Quick Reply' panel, then use the # button; or
    type [code ] before the code and [/code ] after it (without the spaces before the ']').
    Cheers,

    Paul Edstein
    [MS MVP - Word]

  14. #12
    Super Moderator
    Join Date
    May 2002
    Location
    Canberra, Australian Capital Territory, Australia
    Posts
    5,054
    Thanks
    2
    Thanked 417 Times in 346 Posts
    Hi snowshoeken,

    Re footers, what do you want to do with them? They're dependent on Section breaks and replicating those usually means carrying over the page formatting as well. Things become complicated when some Sections in the source document are configured 'link to previous', but the 'previous' for the output document isn't the same previous Section.

    Or do you mean footnotes? Again, replicating those is problematic, because the footnote numbers in the output document will likely differ - you'll possibly already have seen this with the existing procedure.
    Cheers,

    Paul Edstein
    [MS MVP - Word]

  15. #13
    New Lounger
    Join Date
    Dec 2011
    Location
    Central Florida, USA
    Posts
    9
    Thanks
    2
    Thanked 0 Times in 0 Posts
    Unfortumately I do mean footers...I am not sure how they are formatted, but I do no know they vary. Format wise they are the same but contain differnet dates and filing codes. However, the above macros work great! Also, thanks for the info RE: code tags.
    On-On!

    Ken

  16. #14
    Super Moderator
    Join Date
    May 2002
    Location
    Canberra, Australian Capital Territory, Australia
    Posts
    5,054
    Thanks
    2
    Thanked 417 Times in 346 Posts
    Hi snowshoeken,

    Retaining headers & footers requires an entirely different approach. Give the following a whirl:
    Code:
    Sub TestCopier()
    ' Turn Off Screen Updating
    Application.ScreenUpdating = False
    ' Define the variables
    Dim DocOut As Document, RngFnd As Range, Scn As Section
    Dim HdFt As HeaderFooter, StrFnd As String, i As Long
    ' Solicit the string to find
    StrFnd = InputBox("Enter term to find", "Print pages")
    ' Exit if there's no valid input
    If Trim(StrFnd) = "" Then
      MsgBox "Nothing to find", vbExclamation
      Exit Sub
    End If
    ' Copy the input document
    ActiveDocument.Range.Copy
    ' Create and define the output document
    Set DocOut = Documents.Add(DocumentType:=wdNewBlankDocument)
    ' Process the output document
    With DocOut
      ' Turn off change tracking and accept all changes
      .TrackRevisions = False
      .AcceptAllRevisions
      ' Initialize the RngFnd variable
      Set RngFnd = .Range(0, 0)
      With .Range
        'Paste the copied input document. This preserves headers, footers & page layout
        .Paste
      End With
      'Loop through each Section and unlink Header & Footer ranges
      For Each Scn In .Sections
        For Each HdFt In Scn.Headers
          HdFt.LinkToPrevious = False
        Next
        For Each HdFt In Scn.Footers
          HdFt.LinkToPrevious = False
        Next
      Next
      'Loop through each page to find the StrFnd text
      With .Range
        For i = .ComputeStatistics(wdStatisticPages) To 1 Step -1
          Set RngFnd = RngFnd.GoTo(What:=wdGoToPage, Name:=i)
          Set RngFnd = RngFnd.GoTo(What:=wdGoToBookmark, Name:="\page")
          With RngFnd
            With .Find
              .ClearFormatting
              .Text = StrFnd
              .Replacement.Text = ""
              .Forward = True
              .Wrap = wdFindStop
              .Format = True
              .MatchCase = False
              .MatchWholeWord = False
              .MatchWildcards = False
              .MatchSoundsLike = False
              .MatchAllWordForms = False
              .Execute
            End With
            ' If not found, delete the page
            If .Find.Found = False Then
              If .Characters.Last = Chr(12) Then .End = .End - 1
              .Text = vbNullString
            End If
          End With
        Next
      End With
      ' Delete empty Sections. This requires transferring headers & footers from the preceding Section
      While Len(Trim(Replace(Replace(.Sections(1).Range.Text, Chr(12), vbNullString), Chr(13), vbNullString))) = 0
        .Sections(1).Range.Delete
      Wend
      For i = .Sections.Count To 2 Step -1
        With .Sections(i)
        Set Scn = DocOut.Sections(i - 1)
          If Len(Trim(Replace(Replace(.Range.Text, Chr(12), vbNullString), Chr(13), vbNullString))) = 0 Then
          ' The page setup code is only needed if page layouts differ
          With .PageSetup
            .Orientation = Scn.PageSetup.Orientation
            .PageHeight = Scn.PageSetup.PageHeight
            .PageWidth = Scn.PageSetup.PageWidth
            .MirrorMargins = Scn.PageSetup.MirrorMargins
            .TopMargin = Scn.PageSetup.TopMargin
            .BottomMargin = Scn.PageSetup.BottomMargin
            .LeftMargin = Scn.PageSetup.LeftMargin
            .RightMargin = Scn.PageSetup.RightMargin
            .TextColumns = Scn.PageSetup.TextColumns
            If .TextColumns.Count > 1 Then .TextColumns.Spacing = Scn.PageSetup.TextColumns.Spacing
            .DifferentFirstPageHeaderFooter = Scn.PageSetup.DifferentFirstPageHeaderFooter
          End With
            For Each HdFt In .Headers
              With HdFt
                .Range = Scn.Headers(HdFt.Index).Range
                .Range.Characters.Last.Delete
              End With
            Next
            For Each HdFt In .Footers
              With HdFt
                .Range = Scn.Footers(HdFt.Index).Range
                .Range.Characters.Last.Delete
              End With
            Next
            .Range.Previous.Characters.Last.Delete
          End If
        End With
      Next
      ' Clean up the last page
      While .Characters.Last.Previous = vbCr
        .Characters.Last.Delete
      Wend
      ' Save
      .SaveAs FileName:=StrFnd, Fileformat:=wdFormatDocument
    End With
    ' Restore Screen Updating
    Application.ScreenUpdating = True
    ' Inform the user
    MsgBox DocOut.ComputeStatistics(wdStatisticPages) & " pages replicated."
    Set RngFnd = Nothing: Set DocOut = Nothing: Set Scn = Nothing
    End Sub
    Last edited by macropod; 2011-12-09 at 20:48. Reason: Code update - provision for page setup added
    Cheers,

    Paul Edstein
    [MS MVP - Word]

  17. #15
    Super Moderator
    Join Date
    Dec 2000
    Location
    New York, NY
    Posts
    2,970
    Thanks
    3
    Thanked 29 Times in 27 Posts
    Hi Paul,

    True enough. My version was just a quick and dirty rewrite of the original posted code, rather than the more thorough reworking in your code.

    Gary

Page 1 of 2 12 LastLast

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •