Sub HighlightMinus() ' Paul Beverley - Version 15.04.22 ' Removes or adds highlight in a choice of colours doUnderlinesToo = True doColourOffToo = True strikeThroughToo = True addWarning = True doParagraph = True ' False means act on current line Set rng = ActiveDocument.Content If Selection.Text = rng.Text Then If addWarning = True Then Beep myResponse = MsgBox("Remove colour, highlight, strike-through (and underlining)?", _ vbQuestion + vbYesNoCancel, "HighlightMinus") If myResponse <> vbYes Then doUnderlinesToo = False doColourOffToo = False strikeThroughToo = False End If End If Set rng = ActiveDocument.Content rng.HighlightColorIndex = wdNoHighlight If doColourOffToo = True Then rng.Font.Color = wdColorAutomatic If strikeThroughToo = True Then rng.Font.StrikeThrough = False If doUnderlinesToo = True Then rng.Font.Underline = False If ActiveDocument.Footnotes.count > 0 Then Set rng = ActiveDocument.StoryRanges(wdFootnotesStory) rng.HighlightColorIndex = wdNoHighlight If doColourOffToo = True Then rng.Font.Color = wdColorAutomatic If strikeThroughToo = True Then rng.Font.StrikeThrough = False If doUnderlinesToo = True Then rng.Font.Underline = False End If If ActiveDocument.Endnotes.count > 0 Then Set rng = ActiveDocument.StoryRanges(wdEndnotesStory) rng.HighlightColorIndex = wdNoHighlight If strikeThroughToo = True Then rng.Font.StrikeThrough = False If doColourOffToo = True Then rng.Font.Color = wdColorAutomatic If doUnderlinesToo = True Then rng.Font.Underline = False End If Selection.HomeKey Unit:=wdStory Exit Sub End If Dim myCol(9) myCol(0) = wdNoHighlight myCol(1) = wdBrightGreen myCol(2) = wdYellow myCol(3) = wdTurquoise myCol(4) = wdPink myCol(5) = wdRed myCol(6) = wdGreen myCol(7) = wdDarkYellow myCol(8) = wdGray50 myCol(9) = wdGray25 myColTotal = 9 ' Remember track changes status, then switch it off myTrack = ActiveDocument.TrackRevisions ActiveDocument.TrackRevisions = False Dim v As Variable, nowColour As Long varsExist = False For Each v In ActiveDocument.Variables If v.Name = "colNum" Then varsExist = True: Exit For Next v If varsExist = False Then ActiveDocument.Variables.Add "selStart", 0 ActiveDocument.Variables.Add "selEnd", 0 ActiveDocument.Variables.Add "colNum", 0 End If wasStart = ActiveDocument.Variables("selStart") wasEnd = ActiveDocument.Variables("selEnd") wasCol = ActiveDocument.Variables("colNum") ' If no text is selected ... If Selection.Start = Selection.End Then If Selection.Text = vbCr Then Selection.MoveLeft , 1 ' If the cursor is outside the area, give up If Selection.Start < wasStart Or Selection.End _ > wasEnd - 1 Then GoTo LineClear ' Otherwise check the highlight colour Selection.Start = wasStart Selection.End = wasStart + 1 nowColour = Selection.Range.HighlightColorIndex If nowColour <> myCol(wasCol) Then ' colour has changed, so go back to colour 1 nowCol = 0 Else ' go to next colour nowCol = wasCol - 1 If nowCol < 0 Then nowCol = myColTotal End If Selection.End = wasEnd Else ' if some text is selected ' record the current selection range ActiveDocument.Variables("selStart") = Selection.Start ActiveDocument.Variables("selEnd") = Selection.End nowCol = 0 End If ActiveDocument.Variables("colNum") = nowCol ' This following line solves the problem where text ' is highlighted, yet its colour is apparently 0(!) ' so force it to turquoise, then back to 0. If nowCol = 0 And Selection.Range.HighlightColorIndex = 0 Then Selection.Range.HighlightColorIndex = 3 End If Selection.Range.HighlightColorIndex = myCol(nowCol) Selection.End = Selection.Start ActiveDocument.TrackRevisions = myTrack Exit Sub LineClear: If doParagraph = True Then Selection.Expand wdParagraph Else Selection.HomeKey Unit:=wdLine clearStart = Selection.Start Selection.MoveDown Unit:=wdLine, count:=1 Selection.HomeKey Unit:=wdLine End If Set rng = Selection.Range rng.Start = clearStart ActiveDocument.Variables("selStart") = clearStart ActiveDocument.Variables("selEnd") = Selection.End rng.HighlightColorIndex = wdNoHighlight ActiveDocument.TrackRevisions = myTrack Selection.Collapse wdCollapseEnd End Sub