Sub HighlightWordList()
' Paul Beverley - Version 08.02.25
' Highlights and/or font colours all the words/phrases given in a list

doWholeWordsOnly = False
doMatchCase = False
myFileWord = "list"

Set rng = ActiveDocument.Content
Set myDoc = ActiveDocument
gottaList = False
For Each myWordList In Application.Windows
  thisName = myWordList.Document.Name
  If InStr(LCase(thisName), LCase(myFileWord)) > 0 Then
    myWordList.Document.Activate
    myResponse = MsgBox("Is this your list?" & vbCr & vbCr _
         & ">>> " & thisName & " <<<", _
         vbQuestion + vbYesNoCancel, "HighlightWordList")
    If myResponse = vbYes Then
      gottaList = True
      Exit For
    End If
  End If
Next myWordList
If gottaList = False Then
  Beep
  MsgBox "Can't find a word list."
  Exit Sub
End If

nowTrack = myDoc.TrackRevisions
myDoc.TrackRevisions = False
hiColourWas = Options.DefaultHighlightColorIndex

Set myList = myWordList.Document.Content
If rng.Text = myList.Text Then
  Beep
  MsgBox "Please place the cursor in the text to be" & vbCr & "highlighted and rerun the macro."
  Exit Sub
End If
With myList.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "^11"
  .Wrap = wdFindContinue
  .Forward = True
  .Replacement.Text = "^p"
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
  DoEvents
End With


' Build array of words to highlight
numWords = myList.Paragraphs.count
ReDim myWord(numWords) As String
ReDim highColour(numWords) As Long
ReDim fontColour(numWords) As Long

numFRs = 0
For Each myPara In myWordList.Document.Paragraphs
  myText = Replace(myPara.Range.Text, vbCr, "")
  If Left(myText, 1) = "#" Then Exit For
  dotPos = InStr(myText, " . .")
  If dotPos > 0 Then myText = Left(myText, dotPos - 1)
  tabPos = InStr(myText, vbTab)
  If tabPos > 0 Then myText = Mid(myText, tabPos + 1)
  If Len(myText) > 1 And Left(myText, 1) <> "|" Then
    numFRs = numFRs + 1
    myWord(numFRs) = myText
    highColour(numFRs) = myPara.Range.Characters(tabPos + 2).HighlightColorIndex
    fontColour(numFRs) = myPara.Range.Characters(tabPos + 2).Font.Color
  End If
  DoEvents
Next myPara

myDoThese = "TEF"
If myDoc.Footnotes.count = 0 Then _
     myDoThese = Replace(myDoThese, "F", "")
If myDoc.Endnotes.count = 0 Then _
     myDoThese = Replace(myDoThese, "E", "")

For myGo = 1 To Len(myDoThese)
  doWhat = Mid(myDo, myGo, 1)
  Select Case doWhat
     Case "T": Set rng = myDoc.Content
     Case "F": Set rng = myDoc.StoryRanges(wdFootnotesStory)
     Case "E": Set rng = myDoc.StoryRanges(wdEndnotesStory)
  End Select
'Do highlighting on rng
  For i = 1 To numFRs
    Options.DefaultHighlightColorIndex = highColour(i)
    myFind = myWord(i)
    With rng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Wrap = wdFindContinue
      .Text = myFind
      .Font.StrikeThrough = False
      .Replacement.Text = "^&"
      If highColour(i) > 0 Then .Replacement.Highlight = True
      If fontColour(i) > 0 Then .Replacement.Font.Color = fontColour(i)
      .MatchCase = doMatchCase
      .MatchWildcards = False
      .MatchWholeWord = doWholeWordsOnly
      .Execute Replace:=wdReplaceAll
    End With
  Next i
Next myGo
Beep
myDoc.Activate
myDoc.TrackRevisions = nowTrack
Options.DefaultHighlightColorIndex = hiColourWas
End Sub