Extract pages from a word document by finding certain text in them and saving as file

[abhay_547]

Hello, I have a 100+ pages word 2010 document and I have to find certain text in the same and then whichever page consists of that text or word should be saved as a separate file in the same directory where I have the main word document saved. Below is what I have got so far but doesn't help with the finding text and printing.

http://www.vbaexpress.com/kb/getarticle.php?kb_id=727

[gmaxey]

You can add as many bells/whistles as you want but this should get you in the ballpark:


Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oRng As Word.Range
Dim oPageRng As Word.Range
Dim oDocMain As Document, oDocPart As Document
Application.ScreenUpdating = False
Set oDocMain = ActiveDocument
Set oRng = oDocMain.Range
With oRng.Find
.Text = InputBox("Text to find", , "This is a test")
While .Execute
oRng.Select
oDocMain.Bookmarks("\Page").Range.Select
Set oDocPart = Documents.Add
oDocMain.Activate
oDocPart.Range.FormattedText = Selection.Range.FormattedText
oDocPart.SaveAs2 ThisDocument.Path & "\Snippet" & oRng.Information(wdActiveEndPageNumber), wdFormatDocumentDefault
oDocPart.Close wdSaveChanges
oRng.Start = Selection.Range.End
Wend
End With
Application.ScreenUpdating = True
oDocMain.Range(0, 0).Select
lbl_Exit:
Exit Sub
End Sub

[abhay_547]

You can add as many bells/whistles as you want but this should get you in the ballpark:


Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oRng As Word.Range
Dim oPageRng As Word.Range
Dim oDocMain As Document, oDocPart As Document
Application.ScreenUpdating = False
Set oDocMain = ActiveDocument
Set oRng = oDocMain.Range
With oRng.Find
.Text = InputBox("Text to find", , "This is a test")
While .Execute
oRng.Select
oDocMain.Bookmarks("\Page").Range.Select
Set oDocPart = Documents.Add
oDocMain.Activate
oDocPart.Range.FormattedText = Selection.Range.FormattedText
oDocPart.SaveAs2 ThisDocument.Path & "\Snippet" & oRng.Information(wdActiveEndPageNumber), wdFormatDocumentDefault
oDocPart.Close wdSaveChanges
oRng.Start = Selection.Range.End
Wend
End With
Application.ScreenUpdating = True
oDocMain.Range(0, 0).Select
lbl_Exit:
Exit Sub
End Sub



It works like a charm. Thanks a lot :)

I get a blank page with the first snippet file which gets saved .i.e. the first page consists of the text which I had entered in the input box and the second one is blank, not sure why. but this issue is with only the first snippet file rest all look fine. Also can I have the same filename ending with pageNo instead of Snippet.

[gmaxey]

Try:


oDocPart.SaveAs2 ThisDocument.Path & "\" & _
Left(ThisDocument.Name, Len(ThisDocument.Name) - InStrRev(ThisDocument.Name, ".")) "PageNo." & Snippet" & oRng.Information _
(wdActiveEndPageNumber), wdFormatDocumentDefault

[abhay_547]

Now it shows Compile error: Expected: end of statement. On PageNo.

Replaced this line:

oDocPart.SaveAs2 ThisDocument.Path & "\Snippet" & oRng.Information(wdActiveEndPageNumber), wdFormatDocumentDefault

With:

oDocPart.SaveAs2 ThisDocument.Path & "\" & _ Left(ThisDocument.Name, Len(ThisDocument.Name) - InStrRev(ThisDocument.Name, ".")) "PageNo." & Snippet" & oRng.Information _
(wdActiveEndPageNumber), wdFormatDocumentDefault

[gmaxey]

When code doesn't compile they you have to change it until it does:

[abhay_547]

sorry to bug, Now it's not picking the file extension, the files are getting saved without any extension even when we have the wdFormatDocumentDefault at the end. Also it's not picking up the full file name it just picks first 2 or 3 letters and then Pageno.

[gmaxey]

The idea here is to learn to catch your own fish. Not to keeping asking to be spoon fed fish:


Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oRng As Word.Range, oRngPage As Range
Dim oPageRng As Word.Range
Dim oDocMain As Document, oDocPart As Document
Dim strName As String
Set oDocMain = ActiveDocument
Set oRng = oDocMain.Range
With oRng.Find
.Text = InputBox("Text to find", , "This is a test")
While .Execute
oRng.Select
oDocMain.Bookmarks("\Page").Range.Select
Set oRngPage = Selection.Range
strName = ThisDocument.Path & "\" & Left(ThisDocument.Name, _
Len(ThisDocument.Name) - (Len(ThisDocument.Name) - InStrRev(ThisDocument.Name, ".") + 1)) _
& " PageNo. " & oRng.Information(wdActiveEndPageNumber) & ".docx"
Set oDocPart = Documents.Add
oDocMain.Activate
oDocPart.Range.FormattedText = oRngPage.FormattedText
oDocPart.SaveAs2 strName, wdFormatXMLDocument
oDocPart.Close wdSaveChanges
oRng.Start = oRngPage.End
Wend
End With
lbl_Exit:
Exit Sub
End Sub

[abhay_547]

Thanks a lot for your help :) I agreed that I didn't do enough from my end to figure out this but that's only because of time constraint and I have work on multiple document applying same solution and get it ready by Monday morning hence I thought of getting help on the same since it would be bit quicker. thanks again :)


The idea here is to learn to catch your own fish. Not to keeping asking to be spoon fed fish:


Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oRng As Word.Range, oRngPage As Range
Dim oPageRng As Word.Range
Dim oDocMain As Document, oDocPart As Document
Dim strName As String
Set oDocMain = ActiveDocument
Set oRng = oDocMain.Range
With oRng.Find
.Text = InputBox("Text to find", , "This is a test")
While .Execute
oRng.Select
oDocMain.Bookmarks("\Page").Range.Select
Set oRngPage = Selection.Range
strName = ThisDocument.Path & "\" & Left(ThisDocument.Name, _
Len(ThisDocument.Name) - (Len(ThisDocument.Name) - InStrRev(ThisDocument.Name, ".") + 1)) _
& " PageNo. " & oRng.Information(wdActiveEndPageNumber) & ".docx"
Set oDocPart = Documents.Add
oDocMain.Activate
oDocPart.Range.FormattedText = oRngPage.FormattedText
oDocPart.SaveAs2 strName, wdFormatXMLDocument
oDocPart.Close wdSaveChanges
oRng.Start = oRngPage.End
Wend
End With
lbl_Exit:
Exit Sub
End Sub