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

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!

Using the UDF, the answer is no.

No formattting preserved but an alternative approach:

Code:

---

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

---

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 :))

@schroeder:

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

Quote:

---

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

---