Sub FixSpacing()
  Dim oRng As Word.Range
  Set oRng = ActiveDocument.Range
  Set oRng = ActiveDocument.Range
  With oRng.Find
    'Spaces after colon to 2 spaces
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "(:)( {1,9})"
    .Replacement.Text = "\1  "
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
  End With
  TwoSpacesAfterSentence
  Set oRng = ActiveDocument.Range
  With oRng.Find
    'Spaces after ." and .) to 2 spaces
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "(."")( {1,9})"
    .Replacement.Text = "\1  "
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
  End With
  Set oRng = ActiveDocument.Range
  With oRng.Find
    'Spaces after ." and .) to 2 spaces
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "([.\)])( {1,9})([A-Z])"
    .Replacement.Text = "\1  \3"
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
  End With
  Set oRng = ActiveDocument.Range
  'Spaces after a comma or numerical digit and between words to 1 space
  With oRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "([,0-9A-Za-z])( {2,9})"
    .Replacement.Text = "\1 "
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
  End With
  Set oRng = ActiveDocument.Range
  'Space before to no space.
  With oRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "( {1,9})([,.:;])"
    .Replacement.Text = "\2"
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
  End With
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ".."
    .Replacement.Text = "."
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
  End With
End Sub
Sub TwoSpacesAfterSentence()
Dim oRng As Range
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .ClearFormatting
    .MatchWildcards = True
    .Text = "(*{2})([.\!\?]) ([A-Z])"
    .Replacement.Text = "\1\2  \3" 'Two spaces between 2 and \
    .Execute Replace:=wdReplaceAll
    .Text = "([.\!\?]) {3,}([A-Z])"
    .Replacement.Text = "\1  \2"
    .Execute Replace:=wdReplaceAll
    'This should prevent most cases of improper double spacing
    'in names (e.g., F. Lee Bailey, George W. Bush, etc.)
    .Text = "([!A-Z][A-Z].)  ([A-Z])" 'Two spaces between ) and (
    .Replacement.Text = "\1 \2"
    .Execute Replace:=wdReplaceAll
  End With
lbl_Exit:
  Exit Sub
End Sub