Word Macro for multiple searches, incl. in footnotes

[andi.g]

Hello, I am trying to create a macro that searches and highlights all the words in a document, including in the footnotes. The
list of words to highlight is taken from another file (multisearch.docx), and the words in the list are separated by Return/Enter key.
But the search/highlight function only works for the text-body and not for the footnotes. Can anybody tell me
how to modify the vba below to include the footnotes in the search/highlight macro?

------------------------------------------
Sub FindMultiItemsInDoc()
Dim objListDoc As Document
Dim objTargetDoc As Document
Dim objParaRange As Range, objFoundRange As Range
Dim objParagraph As Paragraph

Set objTargetDoc = ActiveDocument
Set objListDoc = Documents.Open(FileName:="C:\multisearch.docx")
objTargetDoc.Activate

For Each objParagraph In objListDoc.Paragraphs
Set objParaRange = objParagraph.Range
objParaRange.End = objParaRange.End - 1

With Selection
.HomeKey Unit:=wdStory

' Find target items.
With Selection.Find
.ClearFormatting
.Text = objParaRange
.MatchWholeWord = True
.MatchCase = False
.Execute
End With

' Highlight the found items.
Do While .Find.Found
Set objFoundRange = Selection.Range
objFoundRange.HighlightColorIndex = wdBrightGreen
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Next objParagraph
End Sub
--------------------------------------------------

Alternatively, i tried to modify this VBA file found here (https://www.office-forums.com/threads/multiple-search-replace-also-in-footnotes.1869777/), but with no succes.

---------------------------------------------------
Public Sub MultiWordFindReplace()

Dim rngstory As Word.Range
Dim ListArray
Dim WordList As Document
Dim i As Long

Set WordList = Documents.Open(FileName:="C:\SR.doc")
ListArray = WordList.Tables(1).Range.Text
ListArray = Split(ListArray, Chr(13) & Chr(7))
WordList.Close
'Fix the skipped blank Header/Footer problem
MakeHFValid
'Iterate through all story types in the current document
For Each rngstory In ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
For i = LBound(ListArray) To UBound(ListArray) - 1 Step 3
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ListArray(i)
.Replacement.Text = ListArray(i + 1)
.MatchWholeWord = True
.Execute Replace:=wdReplaceAll
End With
Next i

Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next

End Sub
Public Sub MakeHFValid()
'And this too
Dim lngJunk As Long
' It does not matter whether we access the Headers or Footers property.
' The critical part is accessing the stories range object
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
End Sub
----------------------------------------------------------
Any help would be appreciated.

 

[macropod]

Cross-posted (and answered before posting here) at: https://answers.microsoft.com/en-us...-incl-in/7ef40859-8eee-405c-8cf8-f7625ff0ec05
For cross-posting etiquette, please read: http://www.excelguru.ca/content.php?184

 

[andi.g]

Received the solution from macropod, thank you. Sorry for the cross-post


Sub BulkFindHighlightOrReplace()
Application.ScreenUpdating = False
Options.DefaultHighlightColorIndex = wdBrightGreen
Dim FRDoc As Document, FRList, j As Long, r As Long, StrFnd As String, StrRep As String
'Load the strings from the reference doc into a text string to be used as an array.
Set FRDoc = Documents.Open("Drive:\FilePath\FindReplaceList.doc", ReadOnly:=True, AddtoRecentfiles:=False, Visible:=False)
FRList = FRDoc.Range.Text
FRDoc.Close False
Set FRDoc = Nothing
With ActiveDocument
For j = 0 To UBound(Split(FRList, vbCr)) - 1
StrFnd = Split(Split(FRList, vbCr)(j), vbTab)(0)
'StrRep = Split(Split(FRList, vbCr)(j), vbTab)(1)
For r = 1 To 2 ' 1 = wdMainTextStory, 2 = wdFootnotesStory, 3 = wdEndnotesStory, etc.
With .StoryRanges(r).Find
.ClearFormatting
.Text = StrFnd
.Forward = True
.Format = True
.Wrap = wdFindStop
.MatchCase = True
.MatchWholeWord = True
.Replacement.Text = "^&" 'StrRep
.Replacement.Highlight = True
.Execute Replace:=wdReplaceAll
End With
Next
Next
End With
Application.ScreenUpdating = True
End Sub