How do I search and highlight multiple terms in Microsoft Word? - vba

Question

My goal is to be able to run this script and have the document search for and highlight a set number of terms, typically 10+ terms. I figured out how to do this with another script I found here, but every time I use it Word crashes.
Below is a simpler version I have pieced together from different forums/videos I found online. It does exactly what I want it to do except I can't figure out how to make it look for more than one term.
The .Text = "Text" works great but only for one term. If I list multiple then it only looks for the one I listed last. I have tested other chunks of code I found online but I can't figure it out.
I am hoping it is a simple fix, especially since the rest of the code does what I want. TIA!
Sub UsingTheFindObject_Medium()
'Declare Variables.
Dim wrdFind As Find
Dim wrdRng As range
Dim wrdDoc As Document
'Grab the ActiveDocument.
Set wrdDoc = Application.ActiveDocument
'Define the Content in the document
Set wrdRng = wrdDoc.Content
'Define the Find Object based on the Range.
Set wrdFind = wrdRng.Find
'Define the parameters of the Search.
With wrdFind
'Search the text for the following term(s)
.Text="Test"
.Format = True
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Do While wrdFind.Execute = True
'Change the color to Yellow.
wrdRng.HighlightColorIndex = wdYellow
Loop
End Sub

Answer 1

This will do what you want.
Sub HighlightMultipleWords()
Dim sArr() As String
Dim rTmp As Range
Dim x As Long
sArr = Split("highlight specific words") ' your list
Options.DefaultHighlightColorIndex = wdYellow
For x = 0 To UBound(sArr)
Set rTmp = ActiveDocument.Range
With rTmp.Find
.Text = sArr(x)
.Replacement.Text = sArr(x)
.Replacement.Highlight = True
.Execute Replace:=wdReplaceAll
End With
Next
End Sub
Before:
After:

Answer 2

Use your current routine as a function.
Here is an example.
Function FindAndMark(sText As String) ' UsingTheFindObject_Medium()
' https://stackoverflow.com/questions/69633517/how-do-i-search-and-highlight-multiple-terms-in-microsoft-word
' Charles Kenyon
'Declare Variables.
Dim wrdFind As Find
Dim wrdRng As Range
Dim wrdDoc As Document
'Grab the ActiveDocument.
Set wrdDoc = Application.ActiveDocument
'Define the Content in the document
Set wrdRng = wrdDoc.Content
'Define the Find Object based on the Range.
Set wrdFind = wrdRng.Find
'Define the parameters of the Search.
With wrdFind
'Search the text for the following term(s)
.Text = sText
.Format = True
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
' Mark text
Do While wrdFind.Execute = True
'Change the color to Yellow.
wrdRng.HighlightColorIndex = wdYellow
Loop
Set wrdFind = Nothing
Set wrdRng = Nothing
Set wrdDoc = Nothing
End Function
Sub MultiFindMark()
' https://stackoverflow.com/questions/69633517/how-do-i-search-and-highlight-multiple-terms-in-microsoft-word
' Charles Kenyon
Dim i As Integer
Const n As Integer = 4 ' set number (n) of terms in search
Dim sArray(n) As String ' Create array to hold terms
' Assign values, starting at 0 and going to n-1
Let sArray(0) = "Aenean"
Let sArray(1) = "Pellentesque"
Let sArray(2) = "libero"
Let sArray(3) = "pharetra"
For i = 0 To n - 1
FindAndMark (sArray(i))
Next i
End Sub
Here is a revision using the code from ASH to handle the Array
Sub MultiFindMark2()
' https://stackoverflow.com/questions/69633517/how-do-i-search-and-highlight-multiple-terms-in-microsoft-word
' Charles Kenyon
' modified to use methods proposed by ASH
Dim i As Long
Dim sArray() As String ' Create array to hold terms
' Assign values, starting at 0 and going to n-1
sArray = Split("Aenean Pellentesque libero pharetra") ' your list separated by spaces
For i = 0 To UBound(sArray)
FindAndMark (sArray(i))
Next i
End Sub
With some of the changes showing as comments:
Sub MultiFindMark2()
' https://stackoverflow.com/questions/69633517/how-do-i-search-and-highlight-multiple-terms-in-microsoft-word
' Charles Kenyon
' modified to use methods proposed by ASH
Dim i As Long
' Const n As Integer = 4 ' set number (n) of terms in search
Dim sArray() As String ' Create array to hold terms
' Assign values, starting at 0 and going to n-1
sArray = Split("Aenean Pellentesque libero pharetra") ' your list separated by spaces
' Let sArray(0) = "Aenean"
' Let sArray(1) = "Pellentesque"
' Let sArray(2) = "libero"
' Let sArray(3) = "pharetra"
For i = 0 To UBound(sArray)
FindAndMark (sArray(i))
Next i
End Sub
Note, this still requires the function.