Copy every occurence of text found by search

[Neil Humphries]

I have a routine to find and replace text in every file in a folder. I am
trying to modify it to find and list in a separate document the paragraph in
which every occurence occurs.

If I am searching for a client name, my document should list the filename
the client's name was found in, followed by the text of each paragraph it was
found in.

I can process a list of files and paste the path and filename into my
document, but I am having difficulty expanding the found text and then
finding the next occurence in the same file.

With the find and replace macro, it seemed to find all the occurences at
once and change them all at the same time. If this is true, can a expand all
the occurences at the same time and copy them all, or do I have to do a
separate find for each occurence and if so then how do I iterate through the
document?

sFileSpec = ActiveDocument.FullName
InsertFileSpec sFileSpec
Windows(UserForm1.lboxFileName.List(I)).Activate
Application.WindowState = wdWindowStateNormal
Selection.HomeKey wdStory
FindandListStory

Sub FindandListStory()
Dim I As Integer
For I = 0 To UBound(arrFindList, 1)
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
End With
With Selection.Find
.Replacement.Highlight = True
.Text = arrFindList(I)
.Forward = True
.Wrap = wdFindStop
.MatchCase = False
.MatchWholeWord = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
If Selection.Find.Found = True Then
GetParagraph
InsertFoundText strTemp
Documents(sSearchFileName).Activate
End If
Next I
End Sub

Sub GetParagraph()
With Selection
.StartOf Unit:=wdParagraph, Extend:=wdExtend
.EndOf Unit:=wdParagraph, Extend:=wdExtend
.TypeBackspace
End With
strTemp = Selection.Text
If Right(strTemp, 1) = vbCr Then _
strTemp = Left(strTemp, Len(strTemp) - 1)

Documents(sMyName).Activate
Set rngEndOfDoc = ActiveDocument.Paragraphs.Last.Range
With rngEndOfDoc
.InsertParagraphAfter
.InsertAfter strTemp
.InsertParagraphAfter
.InsertParagraphAfter
End With

End Sub

 

[Graham Mayor]

Basically you need to find each occurrence of the found text and assign it
to a range.
Then move the start and end of the range to encompass the paragraph
and write the revised range to another document, before collapsing the range
and repeating.

Something along the lines of

Dim SourceDoc As Document
Dim TargetDoc As Document
Dim rPara As Range
Dim vFindText As String
Dim vReplaceText As String

Set SourceDoc = ActiveDocument
Set TargetDoc = Documents.Add
vFindText = "Fred"
vReplaceText = "John"

SourceDoc.Activate
With Selection
.HomeKey wdStory
With .Find
Do While .Execute(findText:=vFindText)
SourceDoc.Activate
Set rPara = Selection.Range 'The found text
rPara.MoveStart wdParagraph, -1
rPara.MoveEnd wdParagraph, 1
rPara = Replace(rPara.Text, _
vFindText, _
vReplaceText)
TargetDoc.Activate
With Selection
.TypeText vFindText & _
" replaced with " & _
vReplaceText & " in"
.TypeParagraph
.TypeText rPara
End With
rPara.Collapse wdCollapseEnd
Loop
End With
End With

--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>