Sub CapitaliseUndoubler()
' Paul Beverley - Version 13.09.19
' Finds doubled capital letters and corrects them

myColour = wdBlue
' myColour = 0
' myHighlight = wdYellow
myHighlight = 0

Set rng = ActiveDocument.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "<[A-Z]{2}[a-z" & ChrW(8217) & "]{2,}>"
  .Wrap = False
  .Replacement.Text = ""
  .Forward = True
  .MatchWildcards = True
  .Execute
End With

myCount = 0
Do While rng.Find.Found = True
  myCount = myCount + 1
  If myColour > 0 Then rng.Font.ColorIndex = myColour
  If myHighlight > 0 Then rng.HighlightColorIndex = myHighlight
  EndNow = rng.End
  rng.Start = rng.Start + 1
  rng.End = rng.Start + 1
  rng.Text = LCase(rng.Text)
  rng.Collapse wdCollapseEnd
  rng.Find.Execute
Loop
MsgBox "Double capitals changed: " & myCount
End Sub