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/wr...-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