Sub TrimSpaces1()
        Dim a As Range, t!
        t = Timer
        For Each a In ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants).Cells
            a = Application.Trim(a)
        Next
        Debug.Print Timer - t
End Sub

Sub TrimSpaces()
        Dim a As Range, t!
        t = Timer
        For Each a In ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants).Areas
            a = Application.Trim(a)
        Next
        Debug.Print Timer - t
End Sub

.Global = True: .MultiLine = True
.Pattern = "^[ " & Chr(160) & "]+": txt = .Replace(txt, "")  'с начала каждой строки
.Pattern = "\s+$": txt = .Replace(txt, "")' в конце каждой строки

With CreateObject("VBScript.RegExp")
     .MultiLine = True
     .Global = True
      
     .Pattern = "^[\xA0 ]+|[\xA0 ]+$"
     x = .Replace(x, "")
      
     .Pattern = "\x20{2,}|\xA0+"
     x = .Replace(x, " ")
End With

Sub Trim_By_Formula()   ' применить функцию СЖПРОБЕЛЫ к видимым ячейкам выделенного диапазона
    If TypeName(Selection) <> "Range" Then Exit Sub
    'If Not TypeOf Selection Is Range Then Exit Sub
    Dim rRange As Range, rAreas As Areas
    With ActiveSheet.UsedRange
       Set rAreas = Intersect(Selection, .SpecialCells(xlCellTypeVisible), .SpecialCells(xlCellTypeConstants)).Areas
    End With
    If rAreas Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    For Each rRange In rAreas
       With rRange
          .Value = Replace(.Value, Chr(160), " ")      ' Chr(160) - неразрывный пробел
          .Value = Application.WorksheetFunction.Trim(.Value)      ' СЖПРОБЕЛЫ
          .Value = Replace(.Value, " " & Chr(10), Chr(10))      ' пробел перед LF
          .Value = Replace(.Value, Chr(10) & " ", Chr(10))      ' пробел после LF
       End With
    Next rRange
    Application.ScreenUpdating = True
    rAreas.Parent.Select
End Sub

Sub Trim_By_Formula()   ' применить функцию СЖПРОБЕЛЫ к видимым ячейкам выделенного диапазона
        If TypeName(Selection) <> "Range" Then Exit Sub
        'If Not TypeOf Selection Is Range Then Exit Sub
        Dim rRange As Range, r As Range
        With ActiveSheet.UsedRange
            Set r = Intersect(Selection, .SpecialCells(xlCellTypeVisible), .SpecialCells(xlCellTypeConstants))
        End With
        Application.ScreenUpdating = False
        With r
            .Replace Chr(160), " ", xlPart' Нефиг это в цикле делать!
            For Each rRange In .Areas
                rRange.Value = Application.Trim(rRange.Value)      ' СЖПРОБЕЛЫ
            Next
            .Replace " " & Chr(10), Chr(10), xlPart      ' пробел перед LF
            .Replace Chr(10) & " ", Chr(10), xlPart       ' пробел после LF
            .Select
        End With
        Application.ScreenUpdating = True
End Sub

With rRange  
           .Value = Replace(.Value, Chr(160), " ")      ' Chr(160)

With r  
             .Replace Chr(160), " ", xlPart

Sub Trim_By_Formula()   ' применить функцию СЖПРОБЕЛЫ к видимым ячейкам выделенного диапазона
    If TypeName(Selection) <> "Range" Then Exit Sub
    'If Not TypeOf Selection Is Range Then Exit Sub
    Dim rRng As Range, rSubRng As Range
    With ActiveSheet.UsedRange
       Set rRng = Intersect(Selection, .SpecialCells(xlCellTypeVisible), .SpecialCells(xlCellTypeConstants))
    End With
    Application.ScreenUpdating = False: Application.EnableEvents = False
    With rRng
       .Replace Chr(160), " ", xlPart   ' Chr(160) - неразрывный пробел
       For Each rSubRng In .Areas
          rSubRng.Value = Application.Trim(rSubRng.Value)   ' СЖПРОБЕЛЫ
       Next
       .Replace " " & Chr(10), Chr(10), xlPart   ' пробел перед LF
       .Replace Chr(10) & " ", Chr(10), xlPart  ' пробел после LF
       .Select
    End With
    Application.ScreenUpdating = True: Application.EnableEvents = True
End Sub

Sub Trim_By_Formula()   ' применить функцию СЖПРОБЕЛЫ к видимым ячейкам выделенного диапазона
    Dim rRng As Range, rSubRng As Range
    Set rRng = Intersect(ActiveWindow.RangeSelection.SpecialCells(xlCellTypeVisible), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants))
    If rRng Is Nothing Then Exit Sub
    Application.ScreenUpdating = False: Application.EnableEvents = False
    With rRng
       .Replace Chr(160), " ", xlPart   ' Chr(160) - неразрывный пробел
       For Each rSubRng In .Areas
          rSubRng.Value = Application.Trim(rSubRng)   ' СЖПРОБЕЛЫ
       Next
       .Replace " " & Chr(10), Chr(10), xlPart   ' пробел перед LF
       .Replace Chr(10) & " ", Chr(10), xlPart  ' пробел после LF
       .Select
    End With
    Application.ScreenUpdating = True: Application.EnableEvents = True
End Sub