Sub HighlightFindDown()
' Paul Beverley - Version 27.01.22
' Selects the next piece of highlighted text

nowColour = Selection.Range.HighlightColorIndex
mixCol = 9999999
myEnd = ActiveDocument.Content.End

myScreenOff = True
If nowColour = mixCol Then
  Set rng = Selection.Range.Duplicate
  rng.End = rng.Start + 1
  nowColour = rng.HighlightColorIndex
End If
If Selection.Start <> Selection.End And nowColour = wdNoHighlight Then _
     Selection.Collapse wdCollapseEnd

If Selection.Start <> Selection.End Then
  If myScreenOff = True Then
    Application.ScreenUpdating = False
    On Error GoTo ReportIt
  End If
' Find this colour only
  findAny = False
  Set rng = Selection.Range.Duplicate
  rng.End = rng.Start + 1
  myColour = rng.HighlightColorIndex
  Do
    rng.End = rng.End + 1
    rng.Start = rng.Start + 1
    nowColour = rng.HighlightColorIndex
    DoEvents
  Loop Until nowColour <> myColour Or rng.End = myEnd
  i = 1
  doneBeep = False
  Do
    rng.End = rng.End + 1
    rng.Start = rng.Start + 1
    nowColour = rng.HighlightColorIndex
    i = i + 1
    If i Mod 100 = 0 Then
      DoEvents
    End If
    If i > 1000 Then
      If doneBeep = False Then
        Beep
        doneBeep = True
      End If
      If i Mod 100 = 0 Then StatusBar = "This takes time, sorry:   " & Str(i)
    End If
  Loop Until nowColour = myColour Or rng.End = myEnd
' Find where this colour stops
  If nowColour = myColour Then
    st = rng.Start
    Do
      rng.End = rng.End + 1
      rng.Start = rng.Start + 1
      nowColour = rng.HighlightColorIndex
      DoEvents
    Loop Until nowColour <> myColour
    rng.End = rng.End - 1
    rng.Start = st
    rng.Select
  End If
Else
' Find any colour
  findAny = True
  Set rng = Selection.Range.Duplicate
  Selection.MoveEnd , 1
  nowColour = Selection.Range.HighlightColorIndex
  If nowColour > 0 Then
    With rng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ""
      .Wrap = wdFindStop
      .Forward = True
      .Highlight = False
      .Replacement.Text = ""
      .Execute
      DoEvents
      If .Found = False Then
        Beep
        rng.Start = myEnd
      End If
      DoEvents
    End With
    rng.Collapse wdCollapseStart
  End If
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Wrap = wdFindStop
    .Forward = True
    .Highlight = True
    .Replacement.Text = ""
    .Execute
    DoEvents
    If .Found = False Then
      Beep
      rng.Start = myEnd
    End If
    DoEvents
  End With
End If
rng.Select

' Flash the range
Application.ScreenUpdating = True
For i = 1 To 2
  DoEvents
  myTime = Timer
  Do
  Loop Until Timer > myTime + 0.08
  Selection.Collapse wdCollapseStart
  DoEvents
  myTime = Timer
  Do
  Loop Until Timer > myTime + 0.08
  rng.Select
Next i
If findAny = True Then Selection.Collapse wdCollapseEnd

' Clear up the F&R
With Selection.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = ""
  .Replacement.Text = ""
  .Forward = True
  .Wrap = wdFindContinue
End With
StatusBar = ""
Exit Sub

ReportIt:
On Error GoTo 0
Resume
End Sub