Place this code In a standard module: 
 
Option Explicit 
 
Sub EliminateMultipleSpaces() 
     'If something goes wrong, go to the errorhandler
    On Error GoTo ERRORHANDLER 
     'Checks the document for excessive spaces between words
    With Selection 
        .HomeKey Unit:=wdStory 
        With .Find 
            .ClearFormatting 
            .Replacement.ClearFormatting 
             'Here is where it is actually looking for spaces between words
            .Text = " [ ]@([! ])" 
             'This line tells it to replace the excessive spaces with one space
            .Replacement.Text = " \1" 
            .MatchWildcards = True 
            .Wrap = wdFindStop 
            .Format = False 
            .Forward = True 
             'execute the replace
            .Execute Replace:=wdReplaceAll 
        End With 
         
        With .Find 
             'This time its looking for excessive spaces after a paragraph mark
            .Text = "^p " 
             'What to replace it with
            .Replacement.Text = "^p" 
            .MatchWildcards = False 
            .Wrap = wdFindStop 
            .Format = False 
            .Forward = True 
             'Execute the replace
            .Execute Replace:=wdReplaceAll 
        End With 
    End With 
ERRORHANDLER: 
    With Selection 
        .ExtendMode = False 
        .HomeKey Unit:=wdStory 
    End With 
End Sub