Sub Demo()
Application.ScreenUpdating = False
Dim Tbl As Table, r As Long, c As Long, Rng As Range
For Each Tbl In ActiveDocument.Tables
  With Tbl
    For r = .Rows.Count To 1 Step -1
      Do While .Cell(r, 1).Range.Paragraphs.Count > 1
        If r < .Rows.Count Then
          .Rows.Add BeforeRow:=.Rows(r + 1)
        Else
          .Rows.Add
        End If
          For c = 1 To .Columns.Count
            Set Rng = .Cell(r, c).Range.Paragraphs.Last.Range
            Rng.End = Rng.End - 1
            With .Cell(r + 1, c).Range.Paragraphs.Last.Range
              .ParagraphFormat = Rng.ParagraphFormat
              .FormattedText = Rng.FormattedText
            End With
            Rng.Start = Rng.Start - 1
            Rng.Delete
          Next
      Loop
    Next
  End With
Next
Application.ScreenUpdating = True
End Sub