Sub ur_()
    a = Range("a1").Value   'текст
    b = Len(a)              'кол-во символом
    'цикл по кол-ву символов
    Dim arr() 'объявим массив
    n = 0
    For d = 1 To b
        'значение ячейки, в которую выгружаем
        c = Sheets("2").Range("a1").Value
        'добавляем к выгрузке символ
        Sheets("2").Range("a1") = c & Mid(a, d, 1)
        c = Sheets("2").Range("a1").Value
        'проверяем высоту строки после выгрузки
        e = Sheets("2").Range("a1").RowHeight
        'переобъявим массив
        ReDim Preserve arr(n)
        'если высота строки > чем по умолчанию
        If e > 15 Then
            f = InStrRev(c, " ") 'ищем пробел
            If f > 0 Then 'если пробел найден
                x = Left(c, f - 1) 'до пробела
                'запищем в ячейку, то что осталось после пробела
                Sheets("2").Range("a1") = Trim(Mid(c, f, b))
            Else
                x = Left(c, Len(c) - 1) 'не включая перенесенный символ
                'запищем в ячейку перенесенный символ
                Sheets("2").Range("a1") = Trim(Right(c, 1))
            End If
            arr(n) = Trim(x) 'запишем текст в массив
            n = n + 1
        End If
        'оставшийся текст
        If d = b Then
            arr(n) = Trim(c)
        End If
    Next
    'очистим ячейку
    Sheets("2").Range("a1").ClearContents
    'выгрузим
    For g = 0 To n
        Range("a" & g + 1) = arr(g)
    Next
End Sub