VBA Macro code to separate a cell into multiple rows at a space - not split text

[Joyner]

Hello, I have not been able to find code here to do what I want, and I can't modify the below code to do what I want, so hopefully someone knows the fix.

I have a range of cells that I need to split into separate cells below the range, (parsed text will be directly below the original text, starting 17 rows below) based on a maximum text length at the space between text.

I found this code from Rick Rothstein (modified for my range and character length) that parses the text perfectly but in the same cell, using a return character and wrapped text format I would like to modify the code so the lines of text are entered in separate cells below, and for each cell parsed I would like a blank line between the rows of texts.

So this (not actual lengths, just as an example) :

A1 VBA Macro code to separate a cell into multiple rows at a space - not split text
A2 I have a range of cells that I need to split into separate cells below the range

Becomes:

A18 VBA Macro code to separate a cell into
A19 multiple rows at a space - not split text
A20 Blank
A21 I have a range of cells that I need to split
A22 into separate cells below the range
A23 Blank
A24 Next cell data and so on

Rick Rothstein's code modified for my length "MaxChars" defined name and my range "CommentList" defined name a block of cells several columns wide and several rows long)

Sorry, I couldn't seem to download the HTML maker - my computer is locked down pretty tight - the indents are showing so hopefully they will stay when I post.:

Thank you for any assistance.

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
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'Const DestinationOffset As Long = 1

'MaxChars = Application.InputBox("Maximum number of characters per line?", Type:=1)
MaxChars = Range("MaxChars")
If MaxChars <= 0 Then Exit Sub
On Error GoTo NoCellsSelected
'Set Source = Application.InputBox("Select cells to process:", Type:=8)
Set Source = Range("CommentList")
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
CellWithText.Offset(17, 0).Value = SplitText & Text
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Exit Sub
NoCellsSelected:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

 

[Joyner]

Hello, I still can't find a solution for this. Should I look for a formula solution? Since I have the code to separate the text inside the cells using the return (char(10) I believe), is there a formula that I can copy down that would separate each cell with the text and returns into separate cells/rows (and also put a blank line between the parsed cells as shown above? Would this question require a separate thread?

Thank you for any assistance.