Find an array of words and highlight them - Word VBA

FindHighlightMultiple.bas

'https://web.archive.org/web/20150420112826/http://help.lockergnome.com/office/Word-2007-Search-multiple-words-document--ftopict1010011.html
Sub HiLightList()
Application.ScreenUpdating = False
Dim vFindText
Dim r As Range
Dim i As Long
vFindText = Array("[!-:(0-9][0-9]{1,}[!-:,.)][!A-Z]", " ten[!a-z]", "eleven", "twelve", "thirteen", "fourteen", "fifteen", "sixteen", "seventeen", "eighteen", "nineteen", "twenty", "thirty", "forty", "fifty", "sixty", "seventy", "eighty", "ninety", "hundred[!s]", "thousand[!s]", ",000,000")

'Add undo function - https://docs.microsoft.com/en-us/office/vba/word/Concepts/Working-with-Word/working-with-the-undorecord-object
Dim objUndo As UndoRecord
Set objUndo = Application.UndoRecord
'Begin the custom undo record and provide a name for the record
objUndo.StartCustomRecord ("Underline problematic numbers")

For i = 0 To UBound(vFindText)
Set r = ActiveDocument.Range
With r.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = vFindText(i)
.MatchWildcards = True
.MatchWholeWord = True
Do While .Execute(Forward:=True) = True
r.Font.Underline = wdUnderlineThick
r.Font.UnderlineColor = 5287936
Loop
End With
Next
Application.ScreenUpdating = True
'End the custom undo record
objUndo.EndCustomRecord

End Sub

Once you've run the script, you can find the highlighted (underlined) words in question by opening the Find/Replace dialog (Ctrl + H) and setting Format > Font to Thick Underline (see the screenshot).