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

[dj44]

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






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

[macropod]

Try, for example:

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

[dj44]

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

[dj44]

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