В выделенном фрагменте Word убрать все лишние пробелы.

Sub Макрос1()
   Dim XL As Object
 
   Set XL = CreateObject("Excel.Application")
   Selection.TypeText Text:=XL.Trim(Selection)
   XL.Quit
   Set XL = Nothing
End Sub

Sub m_1()
Dim myRange As Range
Set myRange = Selection.Range
With myRange.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "[ ^s]{2;}"
    .Replacement.Text = " "
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
    .Text = ""
    .Replacement.Text = ""
    .MatchWildcards = False
End With
Application.Browser.Target = wdBrowsePage
End Sub

Sub m_1()
With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "[ ^s]{2;}"
    .Replacement.Text = " "
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
    .Text = ""
    .Replacement.Text = ""
    .MatchWildcards = False
End With
Application.Browser.Target = wdBrowsePage
End Sub

    .Text = "  "
    .Replacement.Text = " "

t = ActiveDocument.Content.Text