Sub DoubleSpaceCorrect()
' Paul Beverley - Version 20.03.26
' Corrects multiple spaces in the current paragraph or selection

If Selection.Start = Selection.End Then Selection.Expand wdParagraph
Set rng = Selection.Range.Duplicate
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "[ ^s]{2,}"
  .Wrap = wdFindStop
  .Replacement.Text = " "
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
  DoEvents
End With
End Sub