Split Sentence Into 40 Character Whole Words

R

roccoau

New Member
Joined
Dec 25, 2016
Messages
22
Office Version
  1. 365
Hi
I found below code on another site that does most of what I need it to do except for a few things I would like to add if possible.
The code splits all sentence's in column A into maximum character length of 40 whole words in each sentence.
Currently the split 40 character chunks are positioned in the columns next to the original sentence. (column B, C, D etc)
What I would like to achieve if possible is for a new row(s) added below original line(s) and the 40 character chunks added in these blank rows for all sentences in column A

Is this possible ?
Any help would be much appreciated
Tks



Sub breakTextAt40()

'' Cycles through all rows in column A putting a pipe every 40 characters without breaking whole words
For i = 1 To Range("a" & Rows.Count).End(xlUp).Row 'Sets the range to cycle through
Cells(i, 1).Activate 'Selects the cell to be split. i is the row, 1 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 = 40 '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) + 40 'Count the current length of the text and add 40 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
Next



'' Split Column A with Text to Column using Piping as delimiter
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="|", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True


End Sub
 
Sort by date Sort by votes

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce
Rick Rothstein said:
Here is another macro that you can try. It will ask you how many characters per line you want (you would answer 40 as per your original post) and what cells you want to apply the macro to. You can select one or more cells across a single row and their individual text will be split into the cells below it. I have set the offset for the output to skip one row between the original text and the outputted text in order to make it easier to see the outputted results. You can control the output offset by changing the value assigned to the DestinationOffset constant (in the Const statement). Also, if your text is split into separate paragraphs within the source cell, those individual Line Feeds will be respected and the splitting will occur paragraph by paragraph. Here is the macro code...
Code: 
[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub WrapTextOnSpacesWithMaxCharactersPerLine()
  Dim Text As String, LF As Long, TextMax As String, SplitText As String, Lines() 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 = 2

  MaxChars = [B][COLOR=#FF0000]Application.InputBox("Maximum number of characters per line?", Type:=1)[/COLOR][/B]  If MaxChars <= 0 Then Exit Sub
  On Error GoTo NoCellsSelected
  Set Source = [B][COLOR=#008000]Application.InputBox("Either select or type the address range for the cells to process:", Type:=8)[/COLOR][/B]
  On Error GoTo 0
  For Each CellWithText In Source
    Text = CellWithText.Value
    SplitText = ""
    Do While Len(Text) > MaxChars
      TextMax = Left(Text, MaxChars + 1)
      LF = InStr(TextMax, vbLf)
      If LF Then
        SplitText = SplitText & Left(TextMax, LF)
        Text = Mid(Text, LF + 1)
      Else
        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
      End If
    Loop
    If Len(SplitText & Text) Then
      Lines = Split(SplitText & Text, vbLf)
      CellWithText.Offset(DestinationOffset).Resize(UBound(Lines) + 1) = Application.Transpose(Lines)
    End If
  Next
  Exit Sub
NoCellsSelected:
End Sub[/TD]
[/TR]
</tbody>[/TABLE]

Note 1: If you will always want the split to be at 40 characters and never anything different, then replace the red highlighted text with 40.

Note 2: If you will always only be processing cell A1 and never more than that, then replace the green highlighted text with Range("A1").
Click to expand...



Hi Rick
Thanks for your Macro looks interesting and would be another good option for me.
But not sure what I am doing wrong I cannot get it to run.

I get a Compile error: Syntax error. in below ???

MaxChars = Application.InputBox("Maximum number of characters per line?", Type:=1) If MaxChars <= 0 Then Exit Sub

Example here https://we.tl/qaJGJhxk0s
 
Upvote 0
roccoau said:
Hi Rick
Thanks for your Macro looks interesting and would be another good option for me.
But not sure what I am doing wrong I cannot get it to run.

I get a Compile error: Syntax error. in below ???

MaxChars = Application.InputBox("Maximum number of characters per line?", Type:=1) If MaxChars <= 0 Then Exit Sub

Example here https://we.tl/qaJGJhxk0s
Click to expand...
Somehow, two separate lines of code became one when I posted them. The line you posted should have been these two separate lines...

MaxChars = Application.InputBox("Maximum number of characters per line?", Type:=1)
If MaxChars <= 0 Then Exit Sub
 
Upvote 0
Rick Rothstein said:
Somehow, two separate lines of code became one when I posted them. The line you posted should have been these two separate lines...

MaxChars = Application.InputBox("Maximum number of characters per line?", Type:=1)
If MaxChars <= 0 Then Exit Sub
Click to expand...



Hi Rick
Thanks for that , this works great now.
Is there a way of adding lines below the split text and pushing what was in Cell A2 etc down to make room for the split text from A1 ?
At the moment the contents of the cells below is being overwritten

Thanks Rocco
 
Last edited:
Upvote 0
roccoau said:
Hi Rick
Thanks for that , this works great now.
Is there a way of adding lines below the split text and pushing what was in Cell A2 etc down to make room for the split text from A1 ?
Click to expand...
It only took one additional line of code to accommodate your request (highlighted in red below). By the way, while you are working in cell A1, I should point out that my code will work no matter what cell or cells the text is in (when you select the range, that tells the code where to do its work from.
Code: 
[table="width: 500"]
[tr]
	[td]Sub WrapTextOnSpacesWithMaxCharactersPerLine()
  Dim Text As String, LF As Long, TextMax As String, SplitText As String, Lines() 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 = 2

  MaxChars = Application.InputBox("Maximum number of characters per line?", Type:=1)
  If MaxChars <= 0 Then Exit Sub
  On Error GoTo NoCellsSelected
  Set Source = Application.InputBox("Either select or type the address range for the cells to process:", Type:=8)
  On Error GoTo 0
  For Each CellWithText In Source
    Text = CellWithText.Value
    SplitText = ""
    Do While Len(Text) > MaxChars
      TextMax = Left(Text, MaxChars + 1)
      LF = InStr(TextMax, vbLf)
      If LF Then
        SplitText = SplitText & Left(TextMax, LF)
        Text = Mid(Text, LF + 1)
      Else
        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
      End If
    Loop
    If Len(SplitText & Text) Then
      Lines = Split(SplitText & Text, vbLf)
      [B][COLOR="#FF0000"]CellWithText.Offset(1).Resize(UBound(Lines) + 3).Insert xlShiftDown[/COLOR][/B]
      CellWithText.Offset(DestinationOffset).Resize(UBound(Lines) + 1) = Application.Transpose(Lines)
    End If
  Next
  Exit Sub
NoCellsSelected:
End Sub[/td]
[/tr]
[/table]
 
Last edited:
Upvote 0
Rick Rothstein said:
It only took one additional line of code to accommodate your request (highlighted in red below). By the way, while you are working in cell A1, I should point out that my code will work no matter what cell or cells the text is in (when you select the range, that tells the code where to do its work from.
Code: 
[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub WrapTextOnSpacesWithMaxCharactersPerLine()
  Dim Text As String, LF As Long, TextMax As String, SplitText As String, Lines() 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 = 2

  MaxChars = Application.InputBox("Maximum number of characters per line?", Type:=1)
  If MaxChars <= 0 Then Exit Sub
  On Error GoTo NoCellsSelected
  Set Source = Application.InputBox("Either select or type the address range for the cells to process:", Type:=8)
  On Error GoTo 0
  For Each CellWithText In Source
    Text = CellWithText.Value
    SplitText = ""
    Do While Len(Text) > MaxChars
      TextMax = Left(Text, MaxChars + 1)
      LF = InStr(TextMax, vbLf)
      If LF Then
        SplitText = SplitText & Left(TextMax, LF)
        Text = Mid(Text, LF + 1)
      Else
        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
      End If
    Loop
    If Len(SplitText & Text) Then
      Lines = Split(SplitText & Text, vbLf)
      [B][COLOR=#FF0000]CellWithText.Offset(1).Resize(UBound(Lines) + 3).Insert xlShiftDown[/COLOR][/B]
      CellWithText.Offset(DestinationOffset).Resize(UBound(Lines) + 1) = Application.Transpose(Lines)
    End If
  Next
  Exit Sub
NoCellsSelected:
End Sub[/TD]
[/TR]
</tbody>[/TABLE]
Click to expand...


Thank Rick that does the trick... Again :)
Much appreciated

Rocco
 
Upvote 0
Instead of splitting the text into rows below can this be modified to split into multiple columns?

Rick Rothstein said:
Here is another macro that you can try. It will ask you how many characters per line you want (you would answer 40 as per your original post) and what cells you want to apply the macro to. You can select one or more cells across a single row and their individual text will be split into the cells below it. I have set the offset for the output to skip one row between the original text and the outputted text in order to make it easier to see the outputted results. You can control the output offset by changing the value assigned to the DestinationOffset constant (in the Const statement). Also, if your text is split into separate paragraphs within the source cell, those individual Line Feeds will be respected and the splitting will occur paragraph by paragraph. Here is the macro code...
Code: 
[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub WrapTextOnSpacesWithMaxCharactersPerLine()
  Dim Text As String, LF As Long, TextMax As String, SplitText As String, Lines() 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 = 2

  MaxChars = [B][COLOR=#FF0000]Application.InputBox("Maximum number of characters per line?", Type:=1)[/COLOR][/B]  If MaxChars <= 0 Then Exit Sub
  On Error GoTo NoCellsSelected
  Set Source = [B][COLOR=#008000]Application.InputBox("Either select or type the address range for the cells to process:", Type:=8)[/COLOR][/B]
  On Error GoTo 0
  For Each CellWithText In Source
    Text = CellWithText.Value
    SplitText = ""
    Do While Len(Text) > MaxChars
      TextMax = Left(Text, MaxChars + 1)
      LF = InStr(TextMax, vbLf)
      If LF Then
        SplitText = SplitText & Left(TextMax, LF)
        Text = Mid(Text, LF + 1)
      Else
        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
      End If
    Loop
    If Len(SplitText & Text) Then
      Lines = Split(SplitText & Text, vbLf)
      CellWithText.Offset(DestinationOffset).Resize(UBound(Lines) + 1) = Application.Transpose(Lines)
    End If
  Next
  Exit Sub
NoCellsSelected:
End Sub[/TD]
[/TR]
</tbody>[/TABLE]

Note 1: If you will always want the split to be at 40 characters and never anything different, then replace the red highlighted text with 40.

Note 2: If you will always only be processing cell A1 and never more than that, then replace the green highlighted text with Range("A1").
Click to expand...
 
Upvote 0
nathanexcel said:
Instead of splitting the text into rows below can this be modified to split into multiple columns?
Code: 
Sub WrapTextOnSpacesWithMaxCharactersPerLine()
  Dim Text As String, LF As Long, TextMax As String, SplitText As String, Lines() 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 = 2

  MaxChars = Application.InputBox("Maximum number of characters per line?", Type:=1)  If MaxChars <= 0 Then Exit Sub
  On Error GoTo NoCellsSelected
  Set Source = Application.InputBox("Either select or type the address range for the cells to process:", Type:=8)
  On Error GoTo 0
  For Each CellWithText In Source
    Text = CellWithText.Value
    SplitText = ""
    Do While Len(Text) > MaxChars
      TextMax = Left(Text, MaxChars + 1)
      LF = InStr(TextMax, vbLf)
      If LF Then
        SplitText = SplitText & Left(TextMax, LF)
        Text = Mid(Text, LF + 1)
      Else
        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
      End If
    Loop
    If Len(SplitText & Text) Then
      Lines = Split(SplitText & Text, vbLf)
      [B][COLOR="#0000FF"]CellWithText.Offset(DestinationOffset).Resize(UBound(Lines) + 1) = Application.Transpose(Lines)[/COLOR][/B]
    End If
  Next
  Exit Sub
NoCellsSelected:
End Sub
Note 1: If you will always want the split to be at 40 characters and never anything different, then replace the red highlighted text with 40.

Note 2: If you will always only be processing cell A1 and never more than that, then replace the green highlighted text with Range("A1").
Click to expand...
Try changing the blue highlighted line of code toward the end of my procedure to this...
Code: 
   CellWithText.Offset(, DestinationOffset).Resize(, UBound(Lines) + 1) = Lines
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

Kellie220
  • Question
VBA Code Creates Comments with Username and date/timestamp - Need permanent entries
2 3 4
Replies
34
Views
956
DemetriusTheSuperMan
DemetriusTheSuperMan
A
  • Question
VBA Highlight cell if contains specific text
Replies
4
Views
84
DanteAmor
DanteAmor
L
  • Solved
VBA remove leading zeros
2
Replies
14
Views
898
Joe4
Joe4
L
  • Solved
Splitting addresses
Replies
9
Views
973
Fluff
Fluff
F
  • Solved
return "1" IF a word in cell is with red font
Replies
3
Views
464
ferrigeu
F

Forum statistics

Threads
1,214,386
Messages
6,119,212
Members
448,874
Latest member
b1step2far

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top