Here's a procedure that does what you want, subject to the position of
spaces near the MaxLength of the text. IOW, it parses at 2170
characters (or whatever to specify) but checks for the position of the
last space in the string and trims it there.

Sub Parse_CellContents1(TestRange As Range, MaxLength As Long)
' Iterates TestRange for any cells with more than MaxLength characters.
' Parses found cells into subsequent cells immediately below;
' If cell below is not empty then a row is inserted.

Dim rng As Range
Dim sText As String, sTemp As String
Dim lLastRow As Long, lCurRow As Long, lOffset As Long, lPos As Long

With TestRange
lLastRow = Cells(.Rows.Count, .Column).End(xlUp).Row
End With
lOffset = 1
Do Until lCurRow = lLastRow
lCurRow = lCurRow + 1: Set rng = Cells(lCurRow, TestRange.Column)
If Len(rng.Value) MaxLength Then
sText = rng.Text: sTemp = Left$(sText, MaxLength)
lPos = InStrRev(sTemp, " ") '//find the last space
rng.Value = Left$(sText, lPos) '//trim at the space
sText = Mid$(sText, lPos + 1)
Do
sTemp = Left$(sText, MaxLength)
If Len(sTemp) < MaxLength Then lPos = MaxLength _
Else lPos = InStrRev(sTemp, " ")
If Not rng.Offset(lOffset) = Empty Then '//insert a new row
With rng.Offset(lOffset)
.EntireRow.Insert
With .Offset(-1)
.Value = Left(sText, lPos): .WrapText = True
End With
End With
lLastRow = lLastRow + 1 '//add the new row to the row count
Else
With rng.Offset(lOffset)
.Value = Left$(sText, lPos): .WrapText = True
End With
End If
lOffset = lOffset + 1 '//if another row is needed
sText = Mid$(sText, lPos + 1)
Loop Until Len(sText) = 0
End If
lOffset = 1 '//reset for next pass
Loop
End Sub

Sub Test_ParseCellContents()
Parse_CellContents1 Range("A:A"), 2170 '//edit to suit
End Sub

--
Garry

Free usenet access at http://www.eternal-september.org
ClassicVB Users Regroup! comp.lang.basic.visual.misc