VBA code for Text-To-Column delimited with a fixed width.

[Jeremy4110]

Hi, I receive product files from suppliers. The files have a “Description (Long Examples)” (Example 1), the description can be from 10 characters to over a 1000 characters. The system my company uses has a 60 character limit per field. I use “Text-To-Columns”, Delimited, and set the limits at 60, 120, 180, 240, etc. (Example 2). This solves the field limitation problem for my system; however the problem with this is that it will break in the middle of words. I have to manually go back and correct this by taking the first letter or first few letters from column one and move them to the second, and then do the same from second to the third column and so on. (Example 3). Is there a process with VBA that I can use to go from step 1 to step 3 that will make a break at a maximum of 60 characters if it is at the end of a word or back the character limit down to previous space between the last two words? Any help is greatly appreciated, thank you.

Example 1

Description (Long Examples)	Length
SPOT SHOT INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS SPOT SHOT INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS	115
SPOT SHOT INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS SHOT INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS	110
SHOT INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS	100
INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS	95
CARPET STAIN REMOVER & ODOR ELIMINATORS INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS	87
STAIN REMOVER & ODOR ELIMINATORS INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS	80
REMOVER & ODOR ELIMINATORS INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS SPOT SHOT INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS	132
AND ODOR ELIMINATORS INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS SPOT SHOT INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS	126
ELIMINATORS INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS SPOT SHOT INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS	117

<tbody>
</tbody>

Example 2

Description 1	Len 1	Description 2	Len 2	Description 3	Len 3
SPOT SHOT INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS SP	60	OT SHOT INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS	55		0
SPOT SHOT INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS SH	60	OT INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS	50		0
SHOT INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS INSTANT	60	CARPET STAIN REMOVER & ODOR ELIMINATORS	39		0
INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS INSTANT CARP	60	ET STAIN REMOVER & ODOR ELIMINATORS	35		0
CARPET STAIN REMOVER & ODOR ELIMINATORS INSTANT CARPET STAIN	60	REMOVER & ODOR ELIMINATORS	26		0
STAIN REMOVER & ODOR ELIMINATORS INSTANT CARPET STAIN REMOVE	60	R & ODOR ELIMINATORS	20		0
REMOVER & ODOR ELIMINATORS INSTANT CARPET STAIN REMOVER & OD	60	OR ELIMINATORS SPOT SHOT INSTANT CARPET STAIN REMOVER & ODOR	60	ELIMINATORS	11
AND ODOR ELIMINATORS INSTANT CARPET STAIN REMOVER & ODOR ELI	60	MINATORS SPOT SHOT INSTANT CARPET STAIN REMOVER & ODOR ELIMI	60	NATORS	6
ELIMINATORS INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS	59	SPOT SHOT INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS	57		0

<tbody>
</tbody>

Example 3

Description 1	Len 1	Description 2	Len 2	Description 3	Len 3
SPOT SHOT INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS	58	SPOT SHOT INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS	57		0
SPOT SHOT INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS	58	SPOT INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS	52		0
SHOT INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS INSTANT	60	CARPET STAIN REMOVER & ODOR ELIMINATORS	39		0
INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS INSTANT	55	CARPET STAIN REMOVER & ODOR ELIMINATORS	39		0
CARPET STAIN REMOVER & ODOR ELIMINATORS INSTANT CARPET STAIN	60	REMOVER & ODOR ELIMINATORS	26		0
STAIN REMOVER & ODOR ELIMINATORS INSTANT CARPET STAIN	54	REMOVER & ODOR ELIMINATORS	26		0
REMOVER & ODOR ELIMINATORS INSTANT CARPET STAIN REMOVER &	58	ODOR ELIMINATORS SPOT SHOT INSTANT CARPET STAIN REMOVER &	58	ODOR ELIMINATORS	16
AND ODOR ELIMINATORS INSTANT CARPET STAIN REMOVER & ODOR	57	ELIMINATORS SPOT SHOT INSTANT CARPET STAIN REMOVER & ODOR	58	ELIMINATORS	11
ELIMINATORS INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS	59	SPOT SHOT INSTANT CARPET STAIN REMOVER & ODOR ELIMINATORS	57		0

<tbody>
</tbody>

 

[Rick Rothstein]

Give this macro a try (assumes data is in Column A, output starts in Column B)...

[table="width: 500"]
[tr]
	[td]Sub WrapTextOnSpacesWithMaxCharactersPerLine()
  Dim Text As String, TextMax As String, SplitText As String
  Dim Space As Long, MaxChars As Long
  Dim Source As Range, CellWithText As Range
  
  ' With offset as 1, split data will be adjacent to original data
  ' With offset = 0, split data will replace original data
  Const DestinationOffset As Long = 1

  MaxChars = 60 'Application.InputBox("Maximum number of characters per line?", Type:=1)
  Set Source = Range("A1", Cells(Rows.Count, "A").End(xlUp))
  For Each CellWithText In Source
    Text = CellWithText.Value
    SplitText = ""
    Do While Len(Text) > MaxChars
      TextMax = Left(Text, MaxChars + 1)
      If Right(TextMax, 1) = " " Then
        SplitText = SplitText & RTrim(TextMax) & vbLf
        Text = Mid(Text, MaxChars + 2)
      Else
        Space = InStrRev(TextMax, " ")
        If Space = 0 Then
          SplitText = SplitText & Left(Text, MaxChars) & vbLf
          Text = Mid(Text, MaxChars + 1)
        Else
          SplitText = SplitText & Left(TextMax, Space - 1) & vbLf
          Text = Mid(Text, Space + 1)
        End If
      End If
    Loop
    CellWithText.Offset(, DestinationOffset).Value = SplitText & Text
  Next
  Columns("B").TextToColumns Range("B1"), xlDelimited, , , False, False, False, False, True, vbLf
  Exit Sub
NoCellsSelected:
End Sub[/td]
[/tr]
[/table]

 

[footoo]

Here's another way :

Sub TxtToCol()
Dim rng As Range, cel As Range
Dim WrdArray() As String, i%, strg1$, strg2$, c%
Set rng = Range([A1], Cells(Rows.Count, "A").End(xlUp))
For Each cel In rng
    WrdArray() = Split(cel)
    c = 2
    For i = LBound(WrdArray) To UBound(WrdArray)
        If i = 0 Then
            strg2 = WrdArray(i)
        Else
            strg2 = strg1 & " " & WrdArray(i)
        End If
        If Len(strg2) > 60 Then
            Cells(cel.Row, c) = strg1
            c = c + 1
            strg2 = WrdArray(i)
        End If
        If i = UBound(WrdArray) And Len(strg2) < 60 Then
            Cells(cel.Row, c) = strg2
        End If
        strg1 = strg2
    Next
Next
End Sub

 

[footoo]

Revised :

Sub TxtToCol()
Dim rng As Range, cel As Range
Dim WrdArray() As String, i%, strg1$, strg2$, c%
Set rng = Range([A1], Cells(Rows.Count, "A").End(xlUp))
For Each cel In rng
    WrdArray() = Split(cel)
    c = 2
    For i = LBound(WrdArray) To UBound(WrdArray)
        strg2 = strg1 & " " & WrdArray(i)
        If Len(strg2) > 60 Then
            Cells(cel.Row, c) = Trim(strg1)
            c = c + 1
            strg2 = WrdArray(i)
        End If
        If i = UBound(WrdArray) And Len(strg2) < 60 Then
            Cells(cel.Row, c) = Trim(strg2)
        End If
        strg1 = strg2
    Next i
Next
End Sub

 

[footoo]

Again :

Sub TxtToCol()
Dim rng As Range, cel As Range
Dim WrdArray() As String, i%, strg1$, strg2$, c%
Set rng = Range([A1], Cells(Rows.Count, "A").End(xlUp))
For Each cel In rng
    WrdArray() = Split(cel)
    c = 2
    For i = LBound(WrdArray) To UBound(WrdArray)
        strg2 = strg1 & " " & WrdArray(i)
        If Len(strg2) > 60 Then
            Cells(cel.Row, c) = Trim(strg1)
            c = c + 1
            strg2 = WrdArray(i)
        End If
        If i = UBound(WrdArray) And Len(strg2) < 60 Then
            Cells(cel.Row, c) = Trim(strg2)
[COLOR=#ff0000]            strg2 = ""[/COLOR]
        End If
        strg1 = strg2
    Next i
Next
End Sub

 

[Jeremy4110]

Hi Rick,

Thank you so much for your help. I wish I knew what to say besides thank you to show my appreciation. Your code worked perfectly.

I ran your macro against 801 rows of data that I manually spent all day working to complete this past Friday. Your macro matched my manual work in all but two rows. The two differences were my errors, not those of your macro. Also, it took just over a minute to run.

Thanks,
Jeremy

 

[footoo]

Jeremy4110

You're welcome.

 

[Jeremy4110]

Hi footoo,

Thank you for your reply. I ran your last revision for testing against my manual work and against the macro provided by Rick. Your macro was as fast as Rick's but there were a number of differences with the last word. The results of your macro were always under the maximum character limit, but sometimes it was possible to fit the next word and still be under 60 characters. I don't completely understand either macro, but it seems like the difference had to do with the blank space the last words.

Thanks,
Jeremy

 

[footoo]

Hi footoo,

Thank you for your reply. I ran your last revision for testing against my manual work and against the macro provided by Rick. Your macro was as fast as Rick's but there were a number of differences with the last word. The results of your macro were always under the maximum character limit, but sometimes it was possible to fit the next word and still be under 60 characters. I don't completely understand either macro, but it seems like the difference had to do with the blank space the last words.

Thanks,
Jeremy

Yes, that's a problem. My code treats the spaces as characters.
Won't bother changing since Rick's does the job.

 

[Jeremy4110]

Both macros are way above my current ability, but I am learning. I firmly believe that there is no better place to learn then from those who know more than you, and by all means you both know way more than I do. Having this forum has been a great benefit to me and many others. I hope you both know how much people like me appreciate the help.