Public Sub www()
      ActiveSheet.UsedRange.SpecialCells(2).Value = Application.Trim(ActiveSheet.UsedRange.SpecialCells(2).Value)
End Sub

Sub TrimSpaces()
      Dim a As Range
      For Each a In ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants).Areas
          a = Application.Trim(a)
      Next
End Sub

Sub Trim_By_Formula()   ' применить функцию СЖПРОБЕЛЫ к видимым ячейкам выделенного диапазона
     If TypeName(Selection) <> "Range" Then Exit Sub
     Dim rCell As Range, rRange As Range
     With ActiveSheet.Cells
         Set rRange = Intersect(Selection, ActiveSheet.UsedRange, .SpecialCells(xlCellTypeVisible), .SpecialCells(xlCellTypeConstants))
     End With
     If rRange Is Nothing Then Exit Sub
     Application.ScreenUpdating = False
     For Each rCell In rRange
         With rCell
             .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 rCell
     Application.ScreenUpdating = True
     rRange.Select
End Sub

If TypeName(Selection) <> "Range" Then Exit Sub
' ===
If Not TypeOf Selection Is Range Then Exit Sub

Sub Trim_By_Formula()   ' применить функцию СЖПРОБЕЛЫ к видимым ячейкам выделенного диапазона
    If TypeName(Selection) <> "Range" Then Exit Sub
    Dim rCell As Range, rRange As Range
    With ActiveSheet.UsedRange
       Set rRange = Intersect(Selection, .SpecialCells(xlCellTypeVisible), .SpecialCells(xlCellTypeConstants))
    End With
    If rRange Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    For Each rCell In rRange
       With rCell
          .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 rCell
    Application.ScreenUpdating = True
    rRange.Select
End Sub

Sub io()

     Set cell = ActiveCell
      
     tm = Timer
     For i = 1 To 1000000
         bool = TypeName(cell) = "Range"
     Next
     MsgBox Timer - tm
      
      
     tm = Timer
     For i = 1 To 1000000
         bool = TypeOf cell Is Range
     Next
     MsgBox Timer - tm
      
End Sub

Function rgTrim(ByVal txt$) As String
With CreateObject("VBScript.RegExp")
.Global = True: .MultiLine = True
.Pattern = "^[ " & Chr(160) & "]+": txt = .Replace(txt, "")
.Pattern = "\s+$": txt = .Replace(txt, "")
.Pattern = "[ " & Chr(160) & "]+": rgTrim = .Replace(txt$, " ")
End With
End Function

Public Sub www()
         For Each c In Selection.SpecialCells(2, 2)
             c.Value = rgTrim$(c.Value)
         Next
End Sub

Chr(160) === "\xA0"

Sub io()
     x = " " & Chr(160) & Chr(160) & vbNewLine & vbLf
      
     With CreateObject("VBScript.RegExp")
         .Pattern = "[\s\xA0]+"
         x = .Replace(x, " ")
     End With
      
     MsgBox Len(x)
End Sub

Chr(160) === "\xA0"