Public Sub EliminateMultipleSpaces()
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
On Error GoTo BYE
Selection.HomeKey Unit:=wdStory

' Replace one or more spaces followed by something that's not a space.
With Selection.Find
    .Text = " [ ]@([! ])"
    .Replacement.Text = " \1"' With a single space and the non-space something
    .MatchWildcards = True
    .Wrap = wdFindStop
    .Format = False
    .Forward = True
End With
Selection.Find.Execute Replace:=wdReplaceAll

' Replace spaces following returns with just the return.
With Selection.Find
    .Text = "^p "
    .Replacement.Text = "^p"
    .MatchWildcards = False
    .Wrap = wdFindStop
    .Format = False
    .Forward = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
BYE:
Selection.ExtendMode = False
Selection.HomeKey Unit:=wdStory
End Sub