Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range, r As Long, c As Long
With ActiveDocument.Tables(1)
  For r = .Rows.Count To 1 Step -1
    For c = .Columns.Count To 2 Step -1
      If r = .Rows.Count Then
        .Rows.Add
      Else
        .Rows.Add .Rows(r + 1)
      End If
      Set Rng = .Cell(r, c).Range
      Rng.End = Rng.End - 1
      .Cell(r + 1, 1).Range.FormattedText = Rng.FormattedText
    Next
  Next
  For c = .Columns.Count To 2 Step -1
    .Columns(c).Delete
  Next
End With
Application.ScreenUpdating = True
End Sub