PDA

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



ainotayev
06-13-2022, 08:08 AM
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
06-13-2022, 08:43 AM
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
06-13-2022, 09:10 AM
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
06-13-2022, 01:53 PM
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
06-14-2022, 06:30 AM
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
06-14-2022, 07:30 AM
Sheet2.UsedRange.resize(,100)

georgiboy
06-15-2022, 02:31 AM
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
06-15-2022, 05:13 AM
Thank you!