Sub WrapDown_full()
Dim c As Range, myRa As Range
Dim s As String
Dim arr As Variant
Dim arr1 As Variant
Dim i As Integer
Dim d As Variant
Application.ScreenUpdating = False
iRow = Sheets(1).Columns("A").CurrentRegion.Rows.Count
iCol = Sheets(1).Rows(1).CurrentRegion.Columns.Count
yGlobal = 2
yMem = 2
Set this_1 = ThisWorkbook.Sheets(1)
Set this_2 = ThisWorkbook.Sheets(2)
Set MEM = ThisWorkbook.Sheets(2).Cells(1, 655)
    this_2.[A1].CurrentRegion.Offset(1).ClearContents
ReDim arr1(iCol - 1) 'ìàññèâ øèðèí ñòîëáöîâ
For i = 0 To UBound(arr1)
arr1(i) = this_2.Cells(1, i + 1).ColumnWidth
Next i
For x = 2 To iRow
yLocal = yGlobal
    For Z = 1 To iCol '    .Range("c" & y).Value = r.Offset(, 1)
yLocal = yGlobal
arr = Split(this_1.Cells(x, Z), " ")
s = ""
For i = 0 To UBound(arr)
s = s & arr(i) & " "
    this_2.Cells(1, 655) = s
    this_2.Cells(1, 655).EntireColumn.AutoFit
'On Error GoTo ad:
If this_2.Cells(1, 655).ColumnWidth > arr1(Z - 1) Then
      If Len(s) <> Len(arr(i)) + 1 Then
      this_2.Cells(1, 655) = Left(s, Len(s) - Len(arr(i)) - 1) 'áåç ïîñëåäíåãî ñëîâà
         this_2.Cells(yLocal, Z) = this_2.Cells(1, 655)
        
            s = ""
            yLocal = yLocal + 1
            i = i - 1
        Else
        arr1(Z - 1) = this_2.Cells(1, 655).ColumnWidth
        this_2.Cells(yLocal, Z) = Left(s, Len(this_2.Cells(1, 655)) - 1)
        s = ""
        yLocal = yLocal + 1
    End If
End If
If this_2.Cells(1, 655).ColumnWidth < arr1(Z - 1) And i = UBound(arr) Then
        this_2.Cells(yLocal, Z) = this_2.Cells(1, 655)
yLocal = yLocal + 1
Exit For
ElseIf this_2.Cells(1, 655).ColumnWidth > arr1(Z - 1) And i = UBound(arr) Then
    arr1(Z - 1) = this_2.Cells(1, 655).ColumnWidth
    this_2.Cells(yLocal, Z) = this_2.Cells(1, 655)
yLocal = yLocal + 1
Exit For
End If
ad:
Next i
If yLocal > yMem Then
yMem = yLocal
End If
Next Z
yGlobal = yMem
Next x
Application.ScreenUpdating = True
End Sub

Sub ertert()
Dim x, i&
With Range("A1:C" & Cells(Rows.Count, 1).End(xlUp).Row)
    x = .Value: .Offset(1).ClearContents
End With
Application.DisplayAlerts = False
For i = 2 To UBound(x)
    With Cells(Rows.Count, 2).End(xlUp)(2, 1)
        .Offset(, -1).Resize(, UBound(x, 2)).Value = Array(x(i, 1), x(i, 2), x(i, 3))
        .Justify
    End With
Next i
Application.DisplayAlerts = True
End Sub

Sub TOCInRange_vbNewLine()

'Ограниченная версия макроса с заданным разделителем "перенос строки"
'Автор: webley
'Редактор: JayBhagavan
'Сайт: http://planetaexcel.ru

Dim cl As Range, rng As Range, rngTmp As Range
Dim strDelim$, strTmp$
Dim arr() As String
Dim i&, n&, j&, k&

strDelim = Chr(10)
     
    If TypeName(Selection) = "Range" Then
        Set rng = Selection
        n = rng.Rows.Count
        For i = n To 1 Step -1
            With rng(i, 1)
                strTmp = .Value & strDelim
                arr = Split(strTmp, strDelim)
                j = UBound(arr, 1) - 1
                If j > 0 Then
                    .Offset(1).Resize(j).EntireRow.Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromLeftOrAbove
                    Set rngTmp = .Resize(j + 1)
                    For k = 0 To j
                        rngTmp(k + 1, 1).Value = arr(k)
                    Next k
                End If
            End With
        Next i
    End If
End Sub