Microsoft Word, text search and offset Range

[nzepeda]

I understand that this may be the wrong place to ask this question, but I have found this site to be useful with my coding in Excel VBA.

I am trying to use Word VBA to search my document for specific text. After it finds this text I want it to select the Range of 6 lines above 7 columns left of searched text to 17 lines below 7 columns left of searched text.

I can have it do the search with

With Selection.Find
    .Text = "Find Me and select a range around me"
    .Execute
End With

I am having trouble having it select the Range.
In Excel I would normally accomplish this with something like this.

Range(Cell.Offset(-6, -7), Cell.Offset(17, -7))

There is a strong chance that isn't correct, but I would be looking for something like that, in Excel.

I guess my main issue is I can't seem to figure out how to have it set the Range correctly in Word.

Any help would be much aprreciated

 

[Macropod]

Hi nzepeda,

Your description is ambiguous. You say:

After it finds this text I want it to select the Range of 6 lines above 7 columns left of searched text to 17 lines below 7 columns left of searched text

What kind of lines and columns? Text lines & columns or table rows & columns? If it's text lines, do these span different paragraphs? And, having identified the range, why do you want to select it? As with Excel, very little of what you might want to do with a Word range using vba requires the use of Selections.

 

[nzepeda]

It will just be text lines. The information I need to select is spread through different lines with spaces between then, which I guess you can call different paragraphs.

More information:
Turns out that I need all the information from the page the text is located in. Is it possible to have it do my search and once it finds that text selecting the page and coping it to a seperate document.

 

[Macropod]

Turns out that I need all the information from the page the text is located in. Is it possible to have it do my search and once it finds that text selecting the page and coping it to a seperate document.

Yes, you can do that. However, unless you're copying the content to an existing document it's often simpler to delete the unwanted pages then save what's left as a new document.

 

[nzepeda]

Would you happen to know roughly how the code would look so I can give it a try?

 

[Macropod]

Try something along the lines of:

Option Explicit

Sub PageCopier()
' 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", "Find Page Content")
' 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