Split Sentence Into 40 Character Whole Words

[sduttexcel]

I have created a macro to split a column to 40 characters. The split moves to next rows but I want split to move to columns. i.e. If cell A1 is 100 characters long. The split should be B1, C1 and so on. Any help appreciated.

 

[Rick Rothstein]

I have highlighted in red where I get error.

LInesOfLength is the function you posted in Message #1 ... Fluff was just amending the macro part of your posting. That is why I prefaced my code by saying "Here is a fully self-contained macro (no side function calls required)" so that you would not think you needed to retain your LInesOfLength function as opposed to your need to keep it for the code Fluff posted.

 

[sduttexcel]

Hi Rick,

The macro works perfectly when the column is populated. I get the error message when there is a blank column. Say A1 to A5 are populated than A6 is blank than A7 is populated again and so on. Can this be fixed. The data file has no more than 10,000 records, if this will help. many thanks!

Sub SplitTextOnSpacesWithMaxCharactersPerLine() Dim Text As String, TextMax As String, SplitText As String, Answer() As String Dim Space As Long, Source As Range, CellWithText As Range Const MaxChars As Long = 40 Const DestinationOffset As Long = 1 Set Source = Range("A1", Cells(Rows.Count, "A").End(xlUp)) On Error GoTo 0 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 Answer = Split(SplitText & Text, vbLf) CellWithText.Offset(, DestinationOffset).Resize(, UBound(Answer) + 1).Value = Answer Next Exit SubEnd Sub

 

[Rick Rothstein]

Hi Rick,

The macro works perfectly when the column is populated. I get the error message when there is a blank column. Say A1 to A5 are populated than A6 is blank than A7 is populated again and so on. Can this be fixed. The data file has no more than 10,000 records, if this will help. many thanks!

Give this code a try instead then...

[table="width: 500"]
[tr]
	[td]Sub SplitTextOnSpacesWithMaxCharactersPerLine()
  Dim Text As String, TextMax As String, SplitText As String, Answer() As String
  Dim Space As Long, Source As Range, CellWithText As Range

  Const MaxChars As Long = 40
  Const DestinationOffset As Long = 1

  Set Source = Range("A1", Cells(Rows.Count, "A").End(xlUp))
  On Error GoTo 0
  For Each CellWithText In Source
    If Len(CellWithText) Then
      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
      Answer = Split(SplitText & Text, vbLf)
      CellWithText.Offset(, DestinationOffset).Resize(, UBound(Answer) + 1).Value = Answer
    End If
  Next
End Sub[/td]
[/tr]
[/table]

 

[sduttexcel]

Great Thanks!!!