These are not much more than doodles but I think the method works (move up in this caee)
Have a play and see if it can be improved
Sub tabler()
Dim otbl As Table
Dim i As Integer
Dim iRow As Integer
Dim strInsert As String
Dim iCol As Integer
Dim otxtR As TextRange2
Dim lngStart As Long
Dim lngEnd As Long
Dim lngNum As Long
On Error GoTo err
Set otbl = ActiveWindow.Selection.ShapeRange(1).Table
For iRow = 1 To otbl.Rows.Count
For iCol = 1 To otbl.Columns.Count
If otbl.Cell(iRow, iCol).Selected Then
lngStart = startPara(otbl.Cell(iRow, iCol).Shape.TextFrame2.TextRange, ActiveWindow.Selection.TextRange)
If ActiveWindow.Selection.TextRange.Length = 0 Then
lngEnd = lngStart
Else
lngEnd = endPara(otbl.Cell(iRow, iCol).Shape.TextFrame2.TextRange, ActiveWindow.Selection.TextRange)
End If
lngNum = lngEnd - lngStart + 1
If lngStart > 1 Then
otbl.Cell(iRow, iCol).Shape.TextFrame2.TextRange.Paragraphs(lngStart, lngNum).Cut
For i = 1 To lngNum
strInsert = strInsert & vbCrLf
Next
otbl.Cell(iRow, iCol).Shape.TextFrame2.TextRange.Paragraphs(lngStart - 1).InsertBefore (strInsert)
Set otxtR = otbl.Cell(iRow, iCol).Shape.TextFrame2.TextRange
otxtR.Paragraphs(lngStart - 1).Select
ActiveWindow.View.Paste
End If
End If
Next iCol
Next iRow
Exit Sub
err:
MsgBox "ERROR " & err.Description
End Sub
Function startPara(otxR As TextRange2, setTR As TextRange)
Dim p As Integer
For p = 1 To otxR.Paragraphs.Count
If otxR.Paragraphs(p).Start + otxR.Paragraphs(p).Length > setTR.Start Then
startPara = p
Exit For
End If
Next
End Function
Function endPara(otxR As TextRange2, setTR As TextRange)
Dim p As Integer
For p = 1 To otxR.Paragraphs.Count
If setTR.Start + setTR.Length <= otxR.Paragraphs(p).Start + otxR.Paragraphs(p).Length Then
endPara = p
Exit For
End If
Next
End Function