Sub SpaceBallsOneSpace()
  Dim aRng As Range, aSty As Style
  Set aRng = ActiveDocument.Content
  With aRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "^g"
    .Replacement.Text = "^& "
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll
    .Text = "[ ]{2,}"
    .Replacement.Text = " "
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
  End With
End Sub