Page 2 of 2 FirstFirst 12
Results 11 to 16 of 16

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

  1. #11
    Junior Member
    Join Date
    Nov 2014
    Posts
    6
    Rep Power
    0
    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!

  2. #12
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,123
    Rep Power
    10
    Using the UDF, the answer is no.
    Cheers !

    Excel Range to BBCode Table
    Use Social Networking Tools If You Like the Answers !

    Message to Cross Posters

    @ Home - Office 2010/2013/2016 on Win 10 (64 bit); @ Work - Office 2016 on Win 10 (64 bit)

  3. #13
    Senior Member
    Join Date
    Jun 2012
    Posts
    337
    Rep Power
    13
    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

  4. #14
    Junior Member
    Join Date
    Nov 2014
    Posts
    6
    Rep Power
    0
    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 )

  5. #15
    Senior Member
    Join Date
    Jun 2012
    Posts
    337
    Rep Power
    13
    @schroeder:

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

  6. #16
    Forum Guru Rick Rothstein's Avatar
    Join Date
    Feb 2012
    Posts
    662
    Rep Power
    13
    Quote Originally Posted by Admin View Post
    @ 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
    Last edited by Rick Rothstein; 12-20-2016 at 10:01 AM.

Similar Threads

  1. Replies: 6
    Last Post: 06-01-2013, 03:24 PM
  2. Remove Special Characters From Text Or Remove Numbers From Text
    By Excel Fox in forum Excel and VBA Tips and Tricks
    Replies: 5
    Last Post: 05-31-2013, 04:43 PM
  3. Extract Certain Characters From A Text String
    By bobkap in forum Excel Help
    Replies: 5
    Last Post: 05-24-2013, 06:25 AM
  4. Replies: 10
    Last Post: 12-10-2012, 11:28 PM
  5. Replies: 6
    Last Post: 09-26-2011, 07:39 AM

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •