Sub test()
Dim oneCell As Range
Dim Lines As Variant
Dim i As Long
Dim LengthOfLine As Long
LengthOfLine = 40
With Sheet1.Range("A:A")
For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 1 Step -1
Set oneCell = .Cells(i, 1)
With oneCell
Lines = LInesOfLength(LengthOfLine, oneCell.Text)
If 1 < UBound(Lines) Then
.Offset(1, 0).Resize(UBound(Lines) - 1, 1).EntireRow.Insert shift:=xlDown
End If
.Offset(0, 1).Resize(UBound(Lines), 1).Value = Application.Transpose(Lines)
End With
Next i
End With
End Sub
Function LInesOfLength(ByVal LineLength As Long, ByVal aString As String) As Variant
Dim Result() As String
Dim FirstLine As String
Dim LinePointer As Long
aString = Trim(aString)
If aString = vbNullString Then
ReDim Result(1 To 1)
Else
ReDim Result(1 To Len(aString))
Do
FirstLine = Left(aString, LineLength)
If InStr(1, FirstLine, " ") = 0 Then
FirstLine = Split(aString, " ")(0)
Else
If Mid(aString, LineLength + 1, 1) = " " Or Mid(aString, LineLength + 1, 1) = vbNullString Then
Rem done
Else
FirstLine = Left(FirstLine, InStrRev(FirstLine, " ") - 1)
End If
End If
LinePointer = LinePointer + 1
Result(LinePointer) = FirstLine
aString = Trim(Replace(aString, FirstLine, vbNullString, 1, 1))
Loop Until aString = vbNullString
ReDim Preserve Result(1 To LinePointer)
End If
LInesOfLength = Result
End Function