Sub DisplayHighlighterFwd()
' Paul Beverley - Version 01.08.18
' Highlights next word in a display file

displayFile = "zzDisplay"
myColour = wdYellow

Set nowDoc = ActiveDocument.ActiveWindow

' Go and look for the list file
gottaList = False
For i = 1 To Application.Windows.Count
  If InStr(Application.Windows(i).Document.Name, _
       displayFile) > 0 Then
    Set dispDoc = Application.Windows(i).Document
    gottaList = True
    Exit For
  End If
Next i
If gottaList = False Then
  MsgBox ("Couldn't find file: " & displayFile)
  Exit Sub
Else
  dispDoc.Activate
End If

' Find highlighted text
Selection.HomeKey Unit:=wdStory
With Selection.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = ""
  .Highlight = True
  .Execute
End With
If Selection.Find.Found = False Or Len(Selection) < 3 Then
  Selection.HomeKey Unit:=wdStory
  Selection.MoveEndUntil cset:=" ", Count:=wdForward
  Selection.Range.HighlightColorIndex = myColour
Else
  Selection.MoveEndWhile cset:=" ", Count:=wdBackward
  Selection.Range.HighlightColorIndex = wdNoHighlight
  Selection.Collapse wdCollapseEnd
  Selection.MoveStartUntil cset:=" ", Count:=wdForward
  Selection.MoveStartWhile cset:=" ", Count:=wdForward
  Selection.MoveEndUntil cset:=" ", Count:=wdForward
  Selection.Range.HighlightColorIndex = myColour
End If
Selection.Collapse wdCollapseEnd
nowDoc.Activate
End Sub