Wrap Text On Spaces Up To A Maximum Number Of Characters Per Line

**Rick Rothstein** · 04-02-2012, 02:12 PM

NOTE: The code in this message assumes your text does not have any Line Feeds in it. If your code does have Line Feeds, then use the code in Message #16 instead.

This question has come up several times in newsgroups and forums across the years, and it just did so again in another forum I visit, so I thought I would share the solution I posted in response here in this forum. To rephrase the question... you have a text string that you want to wrap into individual lines, with a prescribed maximum number of characters per line, but the line wrapping should only take place at a space between words. As an example, let's say the text string is this...

Today is a fine day to go outside because the weather is so nice.

and you want to line wrap it with no more than 25 characters on any single line. This is how the text should look (remember, we are wrapping text at a blank space only)...

Today is a fine day to go
outside because the
weather is so nice.

If, on the other hand, we were to allow a maximum of 35 characters per line, then the wrapped text would look like this instead...

Today is a fine day to go outside
because the weather is so nice.

Okay, here is a UDF (user defined function) that will perform the appropriate line wrapping (the first argument is the text you want to wrap and the second argument is the maximum number of characters per line)...

Code:

'  Turn the Cell Format "Wrap text" setting
'  on for the cell containing this UDF
Function WrapText(CellWithText As String, MaxChars) As String
  Dim Space As Long, Text As String, TextMax As String
  Text = CellWithText
  Do While Len(Text) > MaxChars
    TextMax = Left(Text, MaxChars + 1)
    If Right(TextMax, 1) = " " Then
      WrapText = WrapText & RTrim(TextMax) & vbLf
      Text = Mid(Text, MaxChars + 2)
    Else
      Space = InStrRev(TextMax, " ")
      If Space = 0 Then
        WrapText = WrapText & Left(Text, MaxChars) & vbLf
        Text = Mid(Text, MaxChars + 1)
      Else
        WrapText = WrapText & Left(TextMax, Space - 1) & vbLf
        Text = Mid(Text, Space + 1)
      End If
    End If
  Loop
  WrapText = WrapText & Text
End Function

If you would rather do the line wrapping using a macro to process an entire column of text rather than using individual UDF formulas, then here is such a macro...

Code:

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 = Application.InputBox("Maximum number of characters per line?", Type:=1)
  If MaxChars <= 0 Then Exit Sub
  On Error GoTo NoCellsSelected
  Set Source = Application.InputBox("Select 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)
      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
  Exit Sub
NoCellsSelected:
End Sub

Note the comment above the line of code where the DestinationOffset constant is set (the Const statement).

HOW TO INSTALL UDFs
------------------------------------
If you are new to UDFs, they are easy to install and use. To install it, simply press ALT+F11 to go into the VB editor and, once there, click Insert/Module on its menu bar, then copy/paste the above code into the code window that just opened up. That's it.... you are done. You can now use WrapText just like it was a built-in Excel function. For example (assuming 35 characters per line),

=WrapText(A1,35)

HOW TO INSTALL MACROs
------------------------------------
If you are new to macros, they are easy to install and use. To install it, simply press ALT+F11 to go into the VB editor and, once there, click Insert/Module on its menu bar, then copy/paste the above code into the code window that just opened up. That's it.... you are done. To use the macro, go back to the worksheet with your data on it and press ALT+F8, select the macro name (WrapTextOnSpacesWithMaxCharactersPerLine) from the list that appears and click the Run button. The macro will execute and perform the action(s) you asked for. If you are using XL2007 or above, make sure you save your file as an "Excel Macro-Enabled Workbook (*.xlsm).

**Schroeder** · 11-16-2014, 03:03 PM

**BJCasler** · 11-18-2014, 09:29 PM

**Schroeder** · 11-18-2014, 09:41 PM

**BJCasler** · 11-19-2014, 01:08 AM

with a delimiter I can split cell into the corresponding columns to the right using text to columns. (doing the same as splitting the cells into those to the right)

this would be to split a cell that contains a list of words into several cells in the same row, separating at the last space within a maximum of 50 characters

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

**Schroeder** · 11-19-2014, 05:16 AM

Thanks, but it seems a step backwards.
Rick's macro (with a tweak) would be more efficient in my workflow.

**Admin** · 11-19-2014, 08:27 AM

@ Rick, I took the freedom to tweak your code to adjust the linebreaks.

Code:

Function WrapText(CellWithText As String, MaxChars) As String
    Dim Space As Long, Text As String, TextMax As String
    Dim vLine As Variant, i As Long
    
    vLine = Split(CellWithText, Chr(10))
    
    For i = 0 To UBound(vLine)
        Text = vLine(i)
        Do While Len(Text) > MaxChars
            TextMax = Left(Text, MaxChars + 1)
            If Right(TextMax, 1) = " " Then
                WrapText = WrapText & RTrim(TextMax) & vbLf
                Text = Mid(Text, MaxChars + 2)
            Else
                Space = InStrRev(TextMax, " ")
                If Space = 0 Then
                    WrapText = WrapText & Left(Text, MaxChars) & vbLf
                    Text = Mid(Text, MaxChars + 1)
                Else
                    WrapText = WrapText & Left(TextMax, Space - 1) & vbLf
                    Text = Mid(Text, Space + 1)
                End If
            End If
        Loop
        WrapText = WrapText & Text & Chr(10)
    Next
    
    WrapText = IIf(Right(WrapText, 1) = Chr(10), Left(WrapText, Len(WrapText) - 1), WrapText)
    
End Function

**Schroeder** · 11-19-2014, 02:40 PM

Thank you very much, Admin!

I'm sorry to ask, but do you think you can tweak the macro too?
(it would be a time-saver)

**Rick Rothstein** · 12-20-2016, 09:47 AM

Originally Posted by Admin

@ Rick, I took the freedom to tweak your code to adjust the linebreaks.

Code:

Function WrapText(CellWithText As String, MaxChars) As String
    Dim Space As Long, Text As String, TextMax As String
    Dim vLine As Variant, i As Long
    
    vLine = Split(CellWithText, Chr(10))
    
    For i = 0 To UBound(vLine)
        Text = vLine(i)
        Do While Len(Text) > MaxChars
            TextMax = Left(Text, MaxChars + 1)
            If Right(TextMax, 1) = " " Then
                WrapText = WrapText & RTrim(TextMax) & vbLf
                Text = Mid(Text, MaxChars + 2)
            Else
                Space = InStrRev(TextMax, " ")
                If Space = 0 Then
                    WrapText = WrapText & Left(Text, MaxChars) & vbLf
                    Text = Mid(Text, MaxChars + 1)
                Else
                    WrapText = WrapText & Left(TextMax, Space - 1) & vbLf
                    Text = Mid(Text, Space + 1)
                End If
            End If
        Loop
        WrapText = WrapText & Text & Chr(10)
    Next
    
    WrapText = IIf(Right(WrapText, 1) = Chr(10), Left(WrapText, Len(WrapText) - 1), WrapText)
    
End Function

I know it is some two years later, but I am thinking I missed the significance of your tweak back then (or maybe I missed the message altogether, I am no longer sure at this late date); however, I have a different way to tweak the code to allow for embedded line feeds. My tweak handles everything within the confines of the exising Do..Loop thus eliminating the need to Split the text and handle the resultant array's elements in a outer loop.

Code:

Function WrapText(CellWithText As String, MaxChars) As String
  Dim Space As Long, LF As Long, Text As String, TextMax As String
  Text = CellWithText
  Do While Len(Text) > MaxChars
    TextMax = Left(Text, MaxChars + 1)
    LF = InStr(TextMax, vbLf)
    If LF Then
      WrapText = WrapText & Left(TextMax, LF)
      Text = Mid(Text, LF + 1)
    Else
      If Right(TextMax, 1) = " " Then
        WrapText = WrapText & RTrim(TextMax) & vbLf
        Text = Mid(Text, MaxChars + 2)
      Else
        Space = InStrRev(TextMax, " ")
        If Space = 0 Then
          WrapText = WrapText & Left(Text, MaxChars) & vbLf
          Text = Mid(Text, MaxChars + 1)
        Else
          WrapText = WrapText & Left(TextMax, Space - 1) & vbLf
          Text = Mid(Text, Space + 1)
        End If
      End If
    End If
  Loop
  WrapText = WrapText & Text
End Function

and here is the tweak for my subroutine...

Code:

Sub WrapTextOnSpacesWithMaxCharactersPerLine()
  Dim Text As String, LF As Long, 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 = Application.InputBox("Maximum number of characters per line?", Type:=1)
  If MaxChars <= 0 Then Exit Sub
  On Error GoTo NoCellsSelected
  Set Source = Application.InputBox("Select 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
    CellWithText.Offset(, DestinationOffset).Value = SplitText & Text
  Next
  Exit Sub
NoCellsSelected:
End Sub

**Admin** · 11-19-2014, 03:44 PM

Code:

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, vLine, i As Long
    
    ' 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 = Application.InputBox("Maximum number of characters per line?", Type:=1)
    If MaxChars <= 0 Then Exit Sub
    On Error GoTo NoCellsSelected
    Set Source = Application.InputBox("Select cells to process:", Type:=8)
    On Error GoTo 0
    For Each CellWithText In Source
        If Len(CellWithText.Value) Then
            vLine = Split(CellWithText.Value, Chr(10))
            SplitText = ""
            For i = 0 To UBound(vLine)
                Text = vLine(i)
                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
                SplitText = SplitText & Text & Chr(10)
            Next
            CellWithText.Offset(, DestinationOffset).Value = IIf(Right(SplitText, 1) = Chr(10), Left(SplitText, Len(SplitText) - 1), SplitText)
        End If
    Next
    Exit Sub
NoCellsSelected:
End Sub