Sub HighlightMinus()
' Paul Beverley - Version 22.02.24
' Adds highlight in a choice of colours

' Make one or other True:
doParagraph = False
doWord = True

Dim myCol(20)
myCol(0) = wdNoHighlight
myCol(1) = wdBrightGreen
myCol(2) = wdYellow
myCol(3) = wdTurquoise
myCol(4) = wdPink
myCol(5) = wdRed
myCol(6) = wdGray50
myCol(7) = wdGray25
myColTotal = 7

' Remember track changes status, then switch it off
myTrack = ActiveDocument.TrackRevisions
ActiveDocument.TrackRevisions = False

Dim v As Variable: Dim nowColour As Long
Dim wasStart As Long: Dim wasEnd As Long
numVars = 0
For Each v In ActiveDocument.Variables
  If v.Name = "colNum" Then numVars = numVars + 1
  If v.Name = "selEnd" Then numVars = numVars + 1
  If v.Name = "selStart" Then numVars = numVars + 1
Next v

If numVars = 1 Or numVars = 2 Then
  numVars = 0
  For i = ActiveDocument.Variables.Count To 1 Step -1
    ActiveDocument.Variables(i).Delete
  Next i
End If

If numVars = 0 Then
  ActiveDocument.Variables.Add "selStart", 0
  ActiveDocument.Variables.Add "selEnd", 0
  ActiveDocument.Variables.Add "colNum", 0
Else
  wasStart = ActiveDocument.Variables("selStart")
  wasEnd = ActiveDocument.Variables("selEnd")
  wasCol = ActiveDocument.Variables("colNum")
End If

' If no text is selected ...
Set rng = Selection.Range.Duplicate
If rng.Start = rng.End Then
  rng.MoveEnd , 1
  If rng.Text = vbCr Then
    rng.MoveStart , -1
    rng.Collapse wdCollapseStart
  Else
    rng.MoveEnd , -1
  End If
  
' Cursor outside the previous range? So start from scratch
  If rng.Start < wasStart Or rng.End > wasEnd Then
  ' If the cursor is outside the previous range
    If doParagraph = True Then
      rng.Expand wdParagraph
    Else
      rng.Expand wdWord
      Do While InStr(ChrW(8217) & "' ", Right(rng.Text, 1)) > 0
        rng.MoveEnd , -1
        DoEvents
      Loop
    End If
    ActiveDocument.Variables("selStart") = rng.Start
    ActiveDocument.Variables("selEnd") = rng.End
 '   Debug.Print rng.Start, rng.End
    nowCol = 0
  Else
    ' Otherwise check the highlight colour
    rng.Start = wasStart
    rng.End = wasStart + 1
    nowColour = rng.HighlightColorIndex
    If nowColour <> myCol(wasCol) Then
      ' colour has changed, so go back to colour 7
      nowCol = 7
    Else
      ' go to next colour
      nowCol = wasCol - 1
      If nowCol < 0 Then nowCol = myColTotal
    End If
    rng.End = wasEnd
  End If
Else:  ' if some text is selected ...
  ' Record current selection range
  ActiveDocument.Variables("selStart") = rng.Start
  ActiveDocument.Variables("selEnd") = rng.End
  nowCol = 0
End If
ActiveDocument.Variables("colNum") = nowCol
rng.HighlightColorIndex = myCol(nowCol)
rng.Collapse wdCollapseStart
rng.Select
theEnd:
ActiveDocument.TrackRevisions = myTrack
End Sub