VBA Macro: Text Split by defined # of characters - word dropping issue

[ainotayev]

Hello.

I have the following macro to split a string into 35 char. sections without breaking full words. It functions but for some reason drops the last 10 characters "(50452770)" of the original string as well as other random ending words like "Charger" from row 12 in the attached sample data;

Sub DescBreakTextA35()
'' Cycles through all rows in column D putting a pipe every 35 characters without breaking whole words
For i = 2 To Range("D" & Rows.Count).End(xlUp).Row 'Sets the range to cycle through
  Cells(i, 4).Activate        'Selects the cell to be split. i is the row, 4 is the column
    Dim str_Out As String     'Variable to hold the new text string as it is created
    Dim iloop As Integer      'Used as a counter for how many words are in the current string
    Dim strString As Variant  'The original string will be split into an array and placed in this holder
    Dim num As Integer        'Holds the max number of characters allowed
    str_Out = ""              'Set empty value to put the new text in
    num = 35                  'Set the max number of characters. This number will increase each time it adds a new delimiter
    strString = Split(ActiveCell.Value, " ")            'Splits the text into an array
    For iloop = LBound(strString) To UBound(strString)  'Sets the number of cycles that the For Loop runs based on how many elements(words) are in the array
        If iloop < UBound(strString) Then               'If the count of iloop is less then the max number of words, then keep running this loop
        str_Out = str_Out & strString(iloop) & " "      'Takes the current string of text, adds the next word in the array, and a Space to separate it from the next word
        If (Len(str_Out) + Len(strString(iloop + 1))) > num Then
        str_Out = str_Out & "|"    'If the length of the current string plus the length of the next word of the string is greater then the text limit, then don't add the next word and add a pipe instead
        num = Len(str_Out) + 35    'Count the current length of the text and add 35 to it
        End If
        End If
    Next
    str_Out = Trim(str_Out)    'Trim any extra whitespace off the text string
    ActiveCell.Value = str_Out 'output the edited text string into the cell that the original text was in
    Range("D:D").Replace What:=" |", Replacement:="|"
    Next
'' Split Column D with Text to Column using Piping as delimiter
Range("D2:D65000").Select
Selection.TextToColumns Destination:=Range("E2"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    :="|", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
Range("D:D").Replace What:="|", Replacement:=" "
End Sub

Could this be an issue with the actual split function?

Thank you!

[snb]

Sub M_snb()
 sn = Sheet2.UsedRange
 
 For j = 2 To UBound(sn)
   sp = Split(sn(j, 4))
   For jj = 0 To UBound(sp)
     If y + Len(sp(jj)) > 35 Then
        y = 0
        sp(jj) = vblf & sp(jj)
      End If
      y = y + Len(sp(jj)) + 1
   Next
   sn(j, 4) = Replace(Join(sp), " " & vbLf, vbLf)
 Next
  
  Cells(20, 1).Resize(UBound(sn), UBound(sn, 2)) = sn
End Sub

[ainotayev]

Thanks!

Some of the splits break at only 3 characters (18"), for example. Any way to put the split text into adjacent New Desc X columns? Mind annotating the code by line for us dummies?

Sub M_snb()
 sn = Sheet2.UsedRange
 
 For j = 2 To UBound(sn)
   sp = Split(sn(j, 4))
   For jj = 0 To UBound(sp)
     If y + Len(sp(jj)) > 35 Then
        y = 0
        sp(jj) = vblf & sp(jj)
      End If
      y = y + Len(sp(jj)) + 1
   Next
   sn(j, 4) = Replace(Join(sp), " " & vbLf, vbLf)
 Next
  
  Cells(20, 1).Resize(UBound(sn), UBound(sn, 2)) = sn
End Sub

[snb]

Sub M_snb()
 sn = Sheet2.UsedRange.resize(,10)
 
 For j = 2 To UBound(sn)
   sp = Split(sn(j, 4))
   For jj = 0 To UBound(sp)
     If y + Len(sp(jj)) > 35 Then
        y = 0
        sp(jj) = vblf & sp(jj)
      End If
      y = y + Len(sp(jj)) + 1
   Next

   sq = split(Join(sp),vblf)
   for jj=0 to ubound(sp)
     sn(j,4+jj)=sq(jj)
   next 
 Next
  
  Cells(20, 1).Resize(UBound(sn), UBound(sn, 2)) = sn
End Sub

[ainotayev]

Morning!

I get a Script out of Range error on sn(j,4+jj)=sq(jj)

Sub M_snb()
 sn = Sheet2.UsedRange.resize(,10)
 
 For j = 2 To UBound(sn)
   sp = Split(sn(j, 4))
   For jj = 0 To UBound(sp)
     If y + Len(sp(jj)) > 35 Then
        y = 0
        sp(jj) = vblf & sp(jj)
      End If
      y = y + Len(sp(jj)) + 1
   Next

   sq = split(Join(sp),vblf)
   for jj=0 to ubound(sp)
     sn(j,4+jj)=sq(jj)
   next 
 Next
  
  Cells(20, 1).Resize(UBound(sn), UBound(sn, 2)) = sn
End Sub

[snb]

Sheet2.UsedRange.resize(,100)

[georgiboy]

Another option to explore (annotated as requested):

Sub test()    
    Dim str As String
    Dim x As Long, nChr As Integer
    Dim oVar As Variant
    Dim rCell As Range
    
    nChr = 35 ' number of characters to split by
    
    For Each rCell In Range("D2", Range("D" & Rows.Count).End(xlUp)).Cells ' loop through the cells in column D - top to bottom
        str = rCell.Text ' set str to the loop cell's text value
        If Len(str) > 0 Then ' check that the string is not empty
            x = 0 ' set x to 0 at the beginning of each row
            ReDim oVar(1 To Len(str) / nChr + 1) ' resize the output array to the number of split texts there will be
            Do Until Len(str) = 0 ' repeat this loop until length of str text = 0
                x = x + 1 ' increment x by 1 (used by the output array: oVar)
                oVar(x) = RTrim(Left(str, InStrRev(str & Space(nChr), " ", nChr + 1) - 1)) ' add split text to output array
                str = Mid(str, Len(oVar(x)) + 2) ' set str to not include the part we just wrote to the output array
            Loop
            rCell.Offset(, 1).Resize(, x).Value = oVar ' write the output array to the cells next to column D
        End If
    Next rCell
End Sub

[ainotayev]

Thank you!