Sub FontFunniesClearAll()
' Paul Beverley - Version 22.07.22
' Changes all text in this specific font into the default font

highlightChanges = True
myColour = wdBrightGreen

badFont = Selection.Font.Name

myTrack = ActiveDocument.TrackRevisions
ActiveDocument.TrackRevisions = False
  
Application.ScreenUpdating = False
On Error GoTo ReportIt
Selection.HomeKey Unit:=wdStory
With Selection.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "^?"
  .Font.Name = badFont
  .Wrap = wdFindStop
  .Replacement.Text = ""
  .Forward = True
  .MatchWildcards = False
  .Execute
End With

myCount = 0
Do While Selection.Find.Found = True
  myCount = myCount + 1
  endNow = Selection.End
  myChar = Asc(Selection.Text)
  myCharW = AscW(Selection.Text)
  isSuper = (Selection.Font.Superscript = True)
  isSub = (Selection.Font.Subscript = True)
  Selection.Delete
  If myCharW < 0 Then
    Selection.Text = Chr(myChar)
  Else
    Selection.Text = ChrW(myCharW)
  End If
  If isSuper = False And isSub = False Then
    If Selection.Font.Superscript = True Then Selection.Font.Superscript = False
    If Selection.Font.Subscript = True Then Selection.Font.Subscript = False
  End If
  If isSuper Then Selection.Font.Superscript = True
  If isSub Then Selection.Font.Subscript = True
  If highlightChanges = True Then Selection.Range.HighlightColorIndex = myColour
  Selection.Start = endNow
  Selection.Find.Execute
Loop
MsgBox "Changed: " & myCount
ActiveDocument.TrackRevisions = myTrack
Application.ScreenUpdating = True
Exit Sub

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