Sub PunctuationToThinSpace()
' Paul Beverley - Version 19.11.21
' Change the next item to a thin space

trackIt = False
makeitColoured = False
myColour = wdYellow
makeNotSubSuper = True

searchChars = " -" & ChrW(160) & ChrW(8201) & Chr(30)

newChar = ChrW(8201)

myTrack = ActiveDocument.TrackRevisions
If trackIt = False Then ActiveDocument.TrackRevisions = False

Set rng = Selection.Range.Duplicate
rng.End = ActiveDocument.Content.End
If Len(rng) > 1000 Then rng.End = rng.Start + 1000

For Each ch In rng.Characters
  If InStr(searchChars, ch.Text) > 0 Then
    ch.Select
    gotChar = True
    Exit For
  Else
  End If
  DoEvents
Next ch
If gotChar = False Then
  Beep
  ActiveDocument.TrackRevisions = myTrack
  Exit Sub
End If
Selection.TypeText Text:=newChar
Selection.MoveStart , -1
If makeitColoured = True Then Selection.Range.HighlightColorIndex = myColour
If Selection.Font.Name = "Symbol" Then Selection.Font.Name = "Times New Roman"
If makeNotSubSuper = True Then
  If Selection.Font.Subscript = True Then Selection.Font.Subscript = False
  If Selection.Font.Superscript = True Then Selection.Font.Superscript = False
End If
Selection.Collapse wdCollapseEnd
ActiveDocument.TrackRevisions = myTrack
End Sub