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