Split Text In To Segments Of Upto X Characters And At The Space Between Words

[BJCasler]

I have a text string, in multiple cells within a column, that I want to separate, with a maximum of 50 numbers characters per line, but the separation should only take place at a space between words.
As an example, let's say the text string is this...

blue red pink floor ground purple tied office hamburger cheese book work today tomorrow yesterday

and I want to separate it to cells to the right with no more than 50 characters in any single cell. This is how the text should look using "|" to represent the next cell (or possible where a delimiter could be placed)...


blue red pink floor ground purple tied office|hamburger cheese book work today tomorrow|yesterday


What i have is not working correctly and locking up excel. Please Help!!

Example:


Option Explicit

Sub termsSplit()
Dim rngData As Range
Dim Cell As Range
Dim arrInput() As String
Dim arrOutput() As String
Dim strValue As String
Dim strTmp As String
Dim n As Long
Dim i As Long
Dim bContinue As Boolean

'// However you set your range//
Set rngData = Selection '<--- using the CodeName (better IMO), or, using the sheet's
'(tab) name---> ThisWorkbook.Worksheets("Sheet2").Range("A1")

For Each Cell In rngData.Cells

strValue = Cell.Value

If Len(strValue) > 50 Then

'// Split the words into an array, using the space as the delimeter. //
arrInput() = Split(strValue, " ")
'// Just clarity //
n = 0: i = 0

'// Outside loop //
Do While n <= UBound(arrInput)

'// Empty the string and set the flag//
strTmp = vbNullString
bContinue = True

'// Test must pass both //
Do While n <= UBound(arrInput, 1) And bContinue
'// If projected temp string length will be below 51... //
If Len(strTmp) + 1 + Len(arrInput(n)) <= 51 Then
'// ...add a space and the next word. //
strTmp = strTmp & Chr$(32) & arrInput(n)
n = n + 1
Else
'// ...else flip the flag. //
bContinue = False
End If
Loop

'// Add an element to our output array and tack our built string into it. //
i = i + 1
ReDim Preserve arrOutput(1 To i)
arrOutput(i) = Trim$(strTmp)

Loop

'// Plunk the results into a sized range //
Cell.Offset(, 1).Resize(, UBound(arrOutput, 1)).Value = arrOutput

Else
Cell.Offset(, 1).Value = Cell.Value
End If

Next

End Sub

[Admin]

Hi

Check out Rick's post here

http://www.excelfox.com/forum/f22/wrap-text-on-spaces-up-to-a-maximum-number-of-characters-per-line-355/

[Excel Fox]

Try this


Sub CallSpliter()

SplitText Worksheets("Sheet1").Range("A1:A100")

End Sub
Sub SplitText(ByRef rngSource As Range)


Const clngSplitLen As Long = 50
Const clngMaxSplits As Long = 99
Dim strText As String
Dim strBreakPoints(1 To clngMaxSplits) As String
Dim lngSplitsCounter As Long
Dim lngIndex As Long
Dim rngCell As Range

For Each rngCell In rngSource
strText = Trim(rngCell.Value)
strBreakPoints(1) = strText
Do While Len(strText) > clngSplitLen
lngSplitsCounter = lngSplitsCounter + 1
If Mid(strText, clngSplitLen + 1, 1) = " " Then
strBreakPoints(lngSplitsCounter) = Left(strText, clngSplitLen)
strText = Trim(Mid(strText, clngSplitLen + 1))
Else
lngIndex = InStrRev(Left(strText, clngSplitLen), " ")
strBreakPoints(lngSplitsCounter) = Trim(Left(strText, lngIndex))
strText = Trim(Mid(strText, lngIndex + 1))
strBreakPoints(lngSplitsCounter + 1) = strText
End If
Loop
rngCell.Offset(, 1).Resize(, lngSplitsCounter + 1).Value = strBreakPoints
strText = vbNullString
lngSplitsCounter = Empty
Erase strBreakPoints
Next rngCell
Set rngCell = Nothing

End Sub