Copy entire page to a text document with find? - vba

Question

I have found many examples of macros to copy selected pages to a new document, however, I am unable to find any examples of macros that use find and replace to locate a word, and copy the entire page containing that word to a new word document or notepad.
Sub PageGrabber()
Dim doc As Word.Document, rng As Word.Range
On Error GoTo ERRORHANDLER
Set doc = ActiveDocument
Set rng = doc.Content
Set rng = doc.Content
With rng.Find
.Text = "help"
.Replacement.Text = " "
.MatchWildcards = False
.Wrap = wdFindStop
.Format = False
.Forward = True
While .Execute
ActiveDocument.Bookmarks("\page").Range.Copy
Documents.Open FileName:="C:\test.docx"
Selection.Paste
rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
Wend
End With
ERRORHANDLER:
If Err.Number <> 0 Then
MsgBox Err.Number & vbCr & Err.Description, vbCritical
Err.Clear
Else
MsgBox "Action Complete"
End If
End Sub
I was attempting to use while .execute during the find to then grab the ActiveDocument.Bookmarks("\page").Range.Copy object and paste it onto a seperate document, it resulted in the first page being copied and nothing else.
If anyone has a link to an example or some useful advice to get this to happen it would be appreciated, thanks.

Answer 1

For example:
Sub PageGrabber()
Application.ScreenUpdating = False
Dim DocSrc As Document, DocTgt As Document
Set DocSrc = ActiveDocument
With DocSrc.Range
With .Find
.Text = "help"
.Replacement.Text = " "
.MatchWildcards = False
.Wrap = wdFindStop
.Format = False
.Forward = True
.Execute
End With
If .Find.Found = True Then
Set DocTgt = Documents.Open(FileName:="C:\test.docx", AddToRecentFiles:=False, Visible:=False)
DocTgt.Range.FormattedText = .Bookmarks("\page").Range.FormattedText
DocTgt.Close True
End If
End With
Set DocTgt = Nothing: Set DocSrc = Nothing
Application.ScreenUpdating = True
End Sub