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

[Admin]

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

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]

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]

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

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.

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

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