Public Function ЗаголовокТекста(WRng As Variant, AddRng As Range, Limit As Integer, Optional Chr As String = "", Optional Bln As Boolean = True)
    With Application: .ScreenUpdating = False: .DisplayAlerts = False: .EnableEvents = False: .Calculation = xlManual: End With
    If Len(WRng) > Limit Then ЗаголовокТекста = IIf(Bln, "-", WRng)
    For Each x In AddRng
        If Len(WRng & Chr & x) <= Limit Then
            ЗаголовокТекста = WRng & Chr & x: Exit For
        End If
    Next x
    With Application: .EnableEvents = True: .DisplayAlerts = True: .ScreenUpdating = True: .Calculation = xlAutomatic: End With
End Function

Function ПереносСлов(Rng1 As Variant, lim1 As Integer)
    On Error Resume Next
    'Application.Volatile True
    Dim tt As String, t As String, t0 As String, i As Integer
    't = ""
    tt = Trim(CStr(Rng1))
    If Len(tt) < lim1 Then
        ПереносСлов = tt: Exit Function
    End If
    arr1 = Split(tt)
    For i = LBound(arr1) To UBound(arr1)
        t0 = t
        t = t & " " & arr1(i)
        t = Trim(t)
        If Len(t) > lim1 Then
            ПереносСлов = t0: Exit Function
        End If
    Next i
End Function

Function ПереносСлов(Rng1 As Variant, lim1 As Integer)
    Dim tt As String, t As String, t0 As String, i As Integer
    tt = Trim(CStr(Rng1))
    If Len(tt) < lim1 Then
        ПереносСлов = tt: Exit Function
    End If
    arr1 = Split(tt & " ")
    For i = LBound(arr1) To UBound(arr1) - 1
        t0 = t
        t = t & " " & arr1(i)
        t = Trim(t)
        If Len(t) > lim1 Then
            ПереносСлов = t0: Exit Function
        End If
    Next i
End Function

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