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

[Rick Rothstein]

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


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


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]

Hi Rick.
I've been using your macro for months now, and it has become essential for my workflow. Thanks a lot!
But since I work a lot with text in Excel, I think it can be slightly improved. Let me explain...

I often need to wrap text in cells with existing linebreaks. Example (original cell):

TITLE

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

Note: there are three linebreaks in this cell, at 1st, 2nd and 3rd line.
Alas, your macro doesn't consider existing linebreaks.
Running the macro with a 35 characters limit, I obtain:

TITLE

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

But it's not correct, because I'd need this:

TITLE

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

Do you think your macro can be tweaked for this purpose?

Thanks in advance!



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


https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA)

[BJCasler]

Using the macro for an entire column,
Instead of wrapping the text,
How would you either insert a delimiter into this location,
OR
Separate data into cells to the right (instead of below)


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

[Schroeder]

Sorry, BJCasler, but I can't clearly understand your reply.

Using the macro for an entire column doesn't change anything, I guess.

Inserting a delimiter? How and why?

Separating data into cell. Yes, this is feasible, but there are two annoyances:
First, at the end you need to put the data together, and with blank lines it needs 2 o 3 more actions.
Second, as far as I know, separating data into cells to right I lose formatting.


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.reddit.com/r/windowsxp/comments/pexq9q/comment/k81ybvj/?utm_source=reddit&utm_medium=web2x&context=3 (https://www.reddit.com/r/windowsxp/comments/pexq9q/comment/k81ybvj/?utm_source=reddit&utm_medium=web2x&context=3)
https://www.youtube.com/watch?v=bs-urI_o8jo&lc=UgxYgiEZuS9I3xkjJv54AaABAg (https://www.youtube.com/watch?v=bs-urI_o8jo&lc=UgxYgiEZuS9I3xkjJv54AaABAg)
https://www.youtube.com/watch?v=bs-urI_o8jo&lc=UgyBACXgNY4j_cHgH5J4AaABAg.9oTkVdzfqfm9wlhQrYJP 3M (https://www.youtube.com/watch?v=bs-urI_o8jo&lc=UgyBACXgNY4j_cHgH5J4AaABAg.9oTkVdzfqfm9wlhQrYJP 3M)
ttps://www.youtube.com/watch?v=LP9fz2DCMBE (ttps://www.youtube.com/watch?v=LP9fz2DCMBE)
https://www.youtube.com/watch?v=LP9fz2DCMBE&lc=UgzbPgJUMCztIOQDym14AaABAg (https://www.youtube.com/watch?v=LP9fz2DCMBE&lc=UgzbPgJUMCztIOQDym14AaABAg)
https://www.youtube.com/watch?v=LP9fz2DCMBE&lc=UgzbPgJUMCztIOQDym14AaABAg.9wdo_rWgxSH9wdpcYqrv p8 (https://www.youtube.com/watch?v=LP9fz2DCMBE&lc=UgzbPgJUMCztIOQDym14AaABAg.9wdo_rWgxSH9wdpcYqrv p8)
ttps://www.youtube.com/watch?v=bFxnXH4-L1A (ttps://www.youtube.com/watch?v=bFxnXH4-L1A)
https://www.youtube.com/watch?v=bFxnXH4-L1A&lc=UgxuODisjo6cvom7O-B4AaABAg.9w_AeS3JiK09wdi2XviwLG (https://www.youtube.com/watch?v=bFxnXH4-L1A&lc=UgxuODisjo6cvom7O-B4AaABAg.9w_AeS3JiK09wdi2XviwLG)
https://www.youtube.com/watch?v=bFxnXH4-L1A&lc=UgxBU39bTptFznDC1PJ4AaABAg (https://www.youtube.com/watch?v=bFxnXH4-L1A&lc=UgxBU39bTptFznDC1PJ4AaABAg)
ttps://www.youtube.com/watch?v=GqzeFYWjTxI (ttps://www.youtube.com/watch?v=GqzeFYWjTxI)
https://www.youtube.com/watch?v=GqzeFYWjTxI&lc=UgwJnJDJ5JT8hFvibt14AaABAg (https://www.youtube.com/watch?v=GqzeFYWjTxI&lc=UgwJnJDJ5JT8hFvibt14AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[BJCasler]

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 (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[Schroeder]

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

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

[Admin]

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

[achar]

Hi All

The code is very useful, thanks!!

Ive stumbled upon a requirement where in the Split Texts need to be pasted in the cells adjacent to the source cell.
As in when text is present in
A1 like "Hi My name is John, i live way back up in the woods in the evergreens, where stood a long cabin, and im a country boy who cannot read and write so well but i can play a guitar just like a ringin a bell"
In B1 the text should be "Hi My name is"
in B2 the text should be "John, i live"
in B3 the text should be "way back up in"
and so on.

Also if I take the input via a userform TEXTBOX, is there a code that will post the lines to destination cells in the above format?
When the input is the Userform1.Textbox1.Text,
the out put should be printed in the cells of column B.


Could please help with this?
Thanks in advance

[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