Split Sentence Into 40 Character Whole Words

[roccoau]

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

 

[mikerickson]

You might use a sub like this

Sub test()
    Dim oneCell As Range
    Dim Lines As Variant
    Dim i As Long
    Dim LengthOfLine As Long
    
    LengthOfLine = 40
    With Sheet1.Range("A:A")
        For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 1 Step -1
            Set oneCell = .Cells(i, 1)
            With oneCell
                Lines = LInesOfLength(LengthOfLine, oneCell.Text)
                If 1 < UBound(Lines) Then
                    .Offset(1, 0).Resize(UBound(Lines) - 1, 1).EntireRow.Insert shift:=xlDown
                End If
                .Offset(0, 1).Resize(UBound(Lines), 1).Value = Application.Transpose(Lines)
            End With
        Next i
    End With
End Sub

Function LInesOfLength(ByVal LineLength As Long, ByVal aString As String) As Variant
    Dim Result() As String
    Dim FirstLine As String
    Dim LinePointer As Long
    
    aString = Trim(aString)
    If aString = vbNullString Then
        ReDim Result(1 To 1)
    Else
        ReDim Result(1 To Len(aString))
        Do
            FirstLine = Left(aString, LineLength)
            If InStr(1, FirstLine, " ") = 0 Then
                FirstLine = Split(aString, " ")(0)
            Else
                If Mid(aString, LineLength + 1, 1) = " " Or Mid(aString, LineLength + 1, 1) = vbNullString Then
                    Rem done
                Else
                    FirstLine = Left(FirstLine, InStrRev(FirstLine, " ") - 1)
                End If
            End If
            
            LinePointer = LinePointer + 1
            Result(LinePointer) = FirstLine
            aString = Trim(Replace(aString, FirstLine, vbNullString, 1, 1))
        Loop Until aString = vbNullString
        
        ReDim Preserve Result(1 To LinePointer)
        
    End If
    LInesOfLength = Result
End Function

 

[roccoau]

You might use a sub like this

Sub test()
    Dim oneCell As Range
    Dim Lines As Variant
    Dim i As Long
    Dim LengthOfLine As Long
    
    LengthOfLine = 40
    With Sheet1.Range("A:A")
        For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 1 Step -1
            Set oneCell = .Cells(i, 1)
            With oneCell
                Lines = LInesOfLength(LengthOfLine, oneCell.Text)
                If 1 < UBound(Lines) Then
                    .Offset(1, 0).Resize(UBound(Lines) - 1, 1).EntireRow.Insert shift:=xlDown
                End If
                .Offset(0, 1).Resize(UBound(Lines), 1).Value = Application.Transpose(Lines)
            End With
        Next i
    End With
End Sub

Function LInesOfLength(ByVal LineLength As Long, ByVal aString As String) As Variant
    Dim Result() As String
    Dim FirstLine As String
    Dim LinePointer As Long
    
    aString = Trim(aString)
    If aString = vbNullString Then
        ReDim Result(1 To 1)
    Else
        ReDim Result(1 To Len(aString))
        Do
            FirstLine = Left(aString, LineLength)
            If InStr(1, FirstLine, " ") = 0 Then
                FirstLine = Split(aString, " ")(0)
            Else
                If Mid(aString, LineLength + 1, 1) = " " Or Mid(aString, LineLength + 1, 1) = vbNullString Then
                    Rem done
                Else
                    FirstLine = Left(FirstLine, InStrRev(FirstLine, " ") - 1)
                End If
            End If
            
            LinePointer = LinePointer + 1
            Result(LinePointer) = FirstLine
            aString = Trim(Replace(aString, FirstLine, vbNullString, 1, 1))
        Loop Until aString = vbNullString
        
        ReDim Preserve Result(1 To LinePointer)
        
    End If
    LInesOfLength = Result
End Function

Hi thanks for you quick response
I am only new to VBA so not 100% sure how all this works.
I tried running this code in a new module but nothing happens.
Any tips on what I am doing wrong
Sorry

 

[Michael M]

Works fine for me.
Is the original data in Col "A"
is the sheet being split the active sheet ?
How are you firing the code ?
CAn you post some sample data that we can test ??

 

[roccoau]

Works fine for me.
Is the original data in Col "A"
is the sheet being split the active sheet ?
How are you firing the code ?
CAn you post some sample data that we can test ??

Hi all
After a bit more testing I did get it to work and it works great. Thanks
I can make this work for me but it was not 100% what I was looking for.
I did want the split 40 character parts to appear in the new rows underneath the original paragraphs in Row A not in Row B as this code does.
(the original lines were to be split at 40 whole words and the balance just appears below it in the newly created lines.)

Thanks again

 

[mikerickson]

To overwrite the existing data, remove the .Offset(0,1) from this section, resulting in this:

    With Sheet1.Range("A:A")
        For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 1 Step -1
            Set oneCell = .Cells(i, 1)
            With oneCell
                Lines = LInesOfLength(LengthOfLine, oneCell.Text)
                If 1 < UBound(Lines) Then
                    .Offset(1, 0).Resize(UBound(Lines) - 1, 1).EntireRow.Insert shift:=xlDown
                End If
                .Resize(UBound(Lines), 1).Value = Application.Transpose(Lines)
            End With
        Next i
    End With

 

[Rick Rothstein]

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

[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 = [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]
[/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").

 

[István Hirsch]

If you are going to use a formula, give this a try. Leave cell A2 empty. Enter the formula in A3 with Ctrl + Shift + Enter, not just Enter.

Excel Workbook
	A	B
1	The awards ceremony is first broadcast to radio in 1930 and televised in 1953. It is now seen live in more than 200 countries and can be streamed live online.[3] The Oscars is the oldest entertainment awards ceremony; its equivalents, the Emmy Awards for television, the Tony Awards for theatre, and the Grammy Awards for music and recording, are modeled after Academy Awards.	376
2	*	0
3	The awards ceremony is first broadcast	38
4	to radio in 1930 and televised in 1953.	39
5	It is now seen live in more than 200	36
6	countries and can be streamed live	34
7	online.[3] The Oscars is the oldest	35
8	entertainment awards ceremony; its	34
9	equivalents, the Emmy Awards for	32
10	television, the Tony Awards for theatre,	40
11	and the Grammy Awards for music and	35
12	recording, are modeled after Academy	36
13	Awards.	7
Sheet

 

[Rick Rothstein]

If you are going to use a formula, give this a try. Leave cell A2 empty. Enter the formula in A3 with Ctrl + Shift + Enter, not just Enter.

Spreadsheet Formulas

Cell Formula A3 {=IFERROR(LEFT(REPLACE(" "&A$1,1,SUMPRODUCT(LEN(A$2:A2)+1),""),MATCH(1,0/SEARCH(" ",MID(REPLACE(A$1&" ",1,SUMPRODUCT(LEN(A$2:A2)+1),""),ROW($1:$40),1)))),"")} A4 {=IFERROR(LEFT(REPLACE(" "&A$1,1,SUMPRODUCT(LEN(A$2:A3)+1),""),MATCH(1,0/SEARCH(" ",MID(REPLACE(A$1&" ",1,SUMPRODUCT(LEN(A$2:A3)+1),""),ROW($1:$40),1)))),"")} <tbody> </tbody>

Formula Array: Produce enclosing { } by entering formula with CTRL+SHIFT+ENTER!

<tbody>
</tbody>

I like your formula solution... one possible problem, maybe... if there are embedded Line Feeds, your formula removes them... note, though, if you decide to modify your formula to respect them, remember you have to start counting from one again with the first non-space text after them and count to 40 from there for the next Line Feed wrap.

 

[roccoau]

To overwrite the existing data, remove the .Offset(0,1) from this section, resulting in this:

    With Sheet1.Range("A:A")
        For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 1 Step -1
            Set oneCell = .Cells(i, 1)
            With oneCell
                Lines = LInesOfLength(LengthOfLine, oneCell.Text)
                If 1 < UBound(Lines) Then
                    .Offset(1, 0).Resize(UBound(Lines) - 1, 1).EntireRow.Insert shift:=xlDown
                End If
                .Resize(UBound(Lines), 1).Value = Application.Transpose(Lines)
            End With
        Next i
    End With

Hi Mike
Thanks for that it works perfect, just what I was looking for

Rgds
Rocco