How to extract sentences containing any of several words using Word VBA

May 25, 2023

I have a Microsoft Word file, Tst.doc that contains the following sentences:

Sofa 1.
Sofa 2.
Chair 1.
Chair 2.
Seat 1.
Seat 2.

I need to extract all the sentences containing any of the words (sofa,chair,seat) to a second file named OutputBin.doc that is stored in a fixed location.

I wrote the following code, based on an existing module that is able to work only on one word, and my code is only working erratically: the relative position of the three words matters, so I believe I am not able to reset the word find range (it is shrinking continuously after each search?)

Sub Extract_MANY_OR()

Dim liste As String
Dim file1 As String
Dim file2 As String: file2 = "D:\OutputBin.doc"

' Change this every time!
file1 = "D:\TST.doc"
liste = "seat,sofa,chair"
 
Dim i As Integer

' assign variables for the documents
    Dim wrdDoc1 As Document: Set wrdDoc1 = Documents.Open(file1)
    Dim wrdDoc2 As Document: Set wrdDoc2 = Documents.Open(file2)
    Dim r1 As Range: Set r1 = wrdDoc1.Range 
    Dim r2 As Range: Set r2 = wrdDoc2.Range

For i = 0 To UBound(Split(liste, ","))

 With r1
  .Find.Text = Split(liste, ",")(i)
  .Find.MatchCase = False '
  ' .Find.MatchCase = True 
  Do While .Find.Execute
   r1.Expand Unit:=wdSentence
   wrdDoc2.Characters.Last.FormattedText = r1.FormattedText
   r2.InsertParagraphAfter
   r1.Collapse wdCollapseEnd
  Loop
 End With

Next i
 
End Sub

>Solution :

You need to reset the search range after each word.

Sub Extract_MANY_OR()

Dim liste As String
Dim file1 As String
Dim file2 As String: file2 = "D:\OutputBin.doc"

' Change this every time!
file1 = "D:\TST.doc"
liste = "seat,sofa,chair"

Dim i As Integer

' assign variables for the documents
Dim wrdDoc1 As Document: Set wrdDoc1 = Documents.Open(file1)
Dim wrdDoc2 As Document: Set wrdDoc2 = Documents.Open(file2)

For i = 0 To UBound(Split(liste, ","))
  ' Reset the range after each word
  Dim r1 As Range: Set r1 = wrdDoc1.Range 
  Dim r2 As Range: Set r2 = wrdDoc2.Range

 With r1
  .Find.Text = Split(liste, ",")(i)
  .Find.MatchCase = False '
  ' .Find.MatchCase = True 
  Do While .Find.Execute
   r1.Expand Unit:=wdSentence
   wrdDoc2.Characters.Last.FormattedText = r1.FormattedText
   r2.InsertParagraphAfter
   r1.Collapse wdCollapseEnd
  Loop
 End With

Next i
 
End Sub