Sub ReduceSpaces()
Dim oRng As Range
  Application.ScreenUpdating = False
  Set oRng = Selection.Range
  With oRng.Find
    .ClearFormatting
    .Text = "^w"
    .Replacement.ClearFormatting
    .Replacement.Font.Size = oRng.Font.Size - 0.5
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll
  End With
  Application.ScreenUpdating = True
lbl_Exit:
  Exit Sub
End Sub