VBA Word - Extract 2 Words Before Word Plus 1 Word - Extract Phrases

Good day folks,

I am attempting to extract some words from my document into another one

I have got stuck on the words range idea


I have listed my words in an array

I want to extract the word plus 2 words before and 1 word after

And i have researched and tried all sorts



End result would be

the blue car is

nice blue car toyota



A blue train which

Expensive great trains are

Code:

---


  Dim i As Long, oWords, RngSrc As Range, RngTgt As Range,
dim DocSrc As Document, Tgt As Document



oWords= Array("Car", "Train")


    Set DocSrc = ActiveDocument
    For i = 0 To UBound(oWords)
    Set DocTgt = Documents.Add
   
   
   
    With DocSrc.Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = oWords(i)
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Execute
    End With
   
    Do While .Find.Found
      Set RngSrc = .Text(1).Range
     
      '  having some trouble here

      'Selection.MoveLeft Unit:=wdWord, Count:=2, Extend:=wdExtend
     
      Set RngTgt = oTgt.Range.Characters.Last
      RngTgt.Collapse wdCollapseStart
      RngTgt.FormattedText = RngSrc.FormattedText
      .Start = RngSrc.End




      .Find.Execute
    Loop
  End With

---

please do add some kindly eyes on this mishmash code



thank you

Try, for example:

Code:

---

Sub Demo()
Dim DocSrc As Document, DocTgt As Document
Dim i As Long, ArrFnd: ArrFnd = Array("[Cc]ar", "[Tt]rain")
Set DocSrc = ActiveDocument: Set DocTgt = Documents.Add
For i = LBound(ArrFnd) To UBound(ArrFnd)
  With DocSrc.Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ArrFnd(i) & " "
      .Replacement.Text = ""
      .Format = False
      .Forward = True
      .Wrap = wdFindStop
      .MatchWildcards = True
      .Execute
    End With
    Do While .Find.Found = True
      With .Duplicate
        .MoveStart wdWord, -3
        Do While .ComputeStatistics(wdStatisticWords) > 3
          .MoveStart wdWord, 1
        Loop
        If .Characters.First Like "[" & Chr(7) & "-" & Chr(13) & "]" Then .MoveStart wdCharacter, 1
        .MoveEnd wdWord, 1
        .MoveEndWhile " ", wdBackward
        DocTgt.Range.InsertAfter vbCr
        DocTgt.Range.Characters.Last.FormattedText = .FormattedText
      End With
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
Next
End Sub

---

Hello Paul,

nice to see you

thank you for the new insights.

I had never seen this before

.ComputeStatistics(wdStatisticWords) > 3 but it looks like a intresting feature i need to put on my list


I was able to do 2 words previously but i was never able to do the

.MoveEndWhile and the wdBackward things

I tried to do this in excel - well im not very good at formulas either :grinhalo:


but suffice to say your code works like a charm

I will modify it and make lots of new ones to help me extract those phrases to help me cut down on my reading verbose stuff

thank you very much for helping like a champ

and great week to you and forum

Thanks again Paul,

So far I have saved 20 minutes on my reading time, I have extracted the important bits, i need and made a summary for myself.

I need things to be bite sized for my reading purposes

And i dont have to keep opening the word document that takes 3 minutes each time and sometimes hangs.

Really appreciate the help!

Good day