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

[Schroeder]

Hi Rick, hi Admin!
Sorry to bother, but I'd like to ask your help again with this macro.

The question is simple...
Do you believe is possible to split text while preserving formatting?
(bold, italic, underline and font color)

The text string is this...
Today is a fine day to go outside because the weather is so nice.

And I need this...
Today is a fine day to go
outside because the
weather is so nice.

It seems difficult to me, but... who knows
Thanks in advance!

[Admin]

Using the UDF, the answer is no.

[snb]

No formattting preserved but an alternative approach:

Sub M_snb()
   MsgBox F_snb_split("Today is a fine day to go outside because the weather is so nice.", 25)
End Sub

Function F_snb_split(c00, y)
   sn = split(Application.Trim(c00))
   
   c00 = sn(0)
   For j = 1 To UBound(sn)
     If Len(c00 & sn(j)) + 1 > y Then
       sn(j - 1) = sn(j - 1) & vbLf
       c00 = sn(j)
     Else
       c00 = c00 & " " & sn(j)
     End If
   Next
   F_snb_split = Replace(Join(sn), vbLf & " ", vbLf)
End Function

[Schroeder]

Really interesting, snb.

Note that your approach doesn't consider the manual linebreaks in the source string.
Perhaps it could be improved (with formatting preserved as well )

[snb]

@schroeder:

there are no manual linebreaks in the source string: see also the title of this thread.

[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