How to split cells containing "hard returns" - vba

Question

How to split cells containing "hard returns" (paragraph marks)
as in the picture below?
the desired result:
Here is my code
Sub SplitCells()
'
Dim selT As String
Dim arr
Dim i As Integer
selT = selection.Range.Text
arr = Split(selT, ChrW(13))
selection.Range.Cut
selection.Cells.Split NumRows:=UBound(arr) + 1, NumColumns:=1, MergeBeforeSplit:=False
selection.MoveDown wdLine, 1
For i = UBound(arr) To 0 Step -1
selection.MoveUp wdLine, 1
selection.TypeText arr(i)
Next
End Sub
It works, but I feel this code is clumsy and hope someone can tell me a elegant way.

Answer 1

Try the following; it will split all affected rows in the selected table.
Sub Demo()
Application.ScreenUpdating = False
Dim Tbl As Table, RngA As Range, RngB As Range
Dim i As Long, l As Long, r As Long, c As Long, p As Long
With Selection
If .Information(wdWithInTable) = False Then
MsgBox "Please select a table/cell and try again."
Exit Sub
End If
Set Tbl = .Tables(1)
With Tbl
l = .Columns.Count
For i = .Range.Cells.Count To 1 Step -1
With .Range.Cells(i).Range
Do While .Characters.Last.Previous = vbCr
.Characters.Last.Previous = vbNullString
Loop
End With
Next
For r = .Rows.Count To 1 Step -1
With .Rows(r)
If .Range.Paragraphs.Count > l + 1 Then
For c = 1 To .Cells.Count
If .Cells(c).Range.Paragraphs.Count > p Then p = .Cells(c).Range.Paragraphs.Count
Next
If p > 1 Then .Cells.Split Numrows:=p, Numcolumns:=1, MergeBeforeSplit:=False
For c = 1 To .Cells.Count
Set RngA = .Cells(c).Range
If RngA.Paragraphs.Count > 1 Then
For p = RngA.Paragraphs.Count To 2 Step -1
Set RngB = RngA.Paragraphs(p).Range
RngB.End = RngB.End - 1
If Len(RngB.Text) > 0 Then
With Tbl.Cell(r + p - 1, c).Range
.FormattedText = RngB.FormattedText
RngB.Delete
End With
End If
RngA.Paragraphs(p - 1).Range.Characters.Last = vbNullString
Next
End If
Next
End If
End With
Next
End With
End With
Application.ScreenUpdating = True
End Sub
Compared to your approach, the above code also has the advantage of preserving any text formatting.

Answer 2

There's nothing wrong with it, really. In order to move up/down in a table with split/merged cells you need Selection...
Here's code that uses the object model instead of Selection as much as possible. But I'm not sure I'd term it "more elegant" or "less clumsy". Possibly, it's more self-documenting since it uses Word objects where ever possible.
One change I did make is to test whether the selection is in a table before doing anything. If the user would forget to select a cell without such a test a cryptic error messsage would display, which is always annoying...
Sub SplitCells()
'
Dim cel As Word.Cell
Dim selT As String
Dim arr
Dim i As Integer
Dim nrCells As Long
If Selection.Information(wdWithInTable) Then
Set cel = Selection.Cells(1)
selT = cel.Range.Text
arr = Split(selT, ChrW(13))
nrCells = UBound(arr)
cel.Range.Delete
cel.Split NumRows:=nrCells, NumColumns:=1 ', _
'MergeBeforeSplit:=False
cel.Select
Selection.MoveDown wdLine, nrCells - 1
For i = nrCells - 1 To 0 Step -1
Set cel = Selection.Cells(1)
cel.Range.Text = arr(i)
cel.Select
Selection.MoveUp wdLine, 1
Next
Else
MsgBox "Please select a table cell and try again."
End If
End Sub