Sub Add_Rows_Table()
Application.ScreenUpdating = False
Dim Tbl As Table, Rng As Range
For Each Tbl In ActiveDocument.Tables
  With Tbl
    .Rows.Add
    Set Rng = .Range
    .Range.Cells(.Range.Cells.Count).Range.InsertBreak Type:=wdColumnBreak
    Rng.Tables(2).Range.Cells.Merge
    .Range.Characters.First.Previous.InsertBefore vbCr
    .Range.Characters.First.Previous.Previous.FormattedText = Rng.Tables(2).Range.FormattedText
    Rng.Tables(2).Delete
    .Range.Characters.First.Previous.Delete
    .Range.Characters.Last.Next.Delete
  End With
Next Tbl
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub