Sub HighlightFindUp()
' Paul Beverley - Version 27.01.22
' Selects the previous piece of highlighted text

nowColour = Selection.Range.HighlightColorIndex
mixCol = 9999999

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 wdCollapseStart

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.Start = rng.Start - 1
    rng.End = rng.End - 1
    nowColour = rng.HighlightColorIndex
    DoEvents
  Loop Until nowColour <> myColour Or rng.Start = 0
  i = 1
  doneBeep = False
  Do
    rng.Start = rng.Start - 1
    rng.End = rng.End - 1
    nowColour = rng.HighlightColorIndex
    DoEvents
    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.Start = 0
' Find where this colour stops
  If nowColour = myColour Then
    en = rng.End
    Do
      rng.Start = rng.Start - 1
      rng.End = rng.End - 1
      nowColour = rng.HighlightColorIndex
      DoEvents
    Loop Until nowColour <> myColour
    rng.Start = rng.Start + 1
    adsgf = rng.Start
    rng.End = en
    rng.Select
  End If
Else
' Find any colour
  Application.ScreenUpdating = False
  findAny = True
  Set rng = Selection.Range.Duplicate
  Selection.MoveStart , -1
  nowColour = Selection.Range.HighlightColorIndex
  If nowColour > 0 Then
    With rng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ""
      .Wrap = wdFindStop
      .Forward = False
      .Highlight = False
      .Replacement.Text = ""
      .Execute
      DoEvents
      If .Found = False Then
        Beep
        rng.Start = myEnd
      End If
    End With
    DoEvents
    rng.Collapse wdCollapseStart
  End If
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Wrap = wdFindStop
    .Forward = False
    .Highlight = True
    .Replacement.Text = ""
    .Execute
    DoEvents
    If .Found = False Then
      Beep
      rng.End = 0
    End If
  End With
  DoEvents
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 wdCollapseStart
Else
  rng.Select
End If
If rng.Start = 0 Then
  Beep
  Selection.Collapse wdCollapseStart
End If

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

ReportIt:
Application.ScreenUpdating = True
On Error GoTo 0
Resume
End Sub