Sub SplitVertMergeCells()
  Dim aTbl As Table, aCell As Cell, i As Integer, aRng As Range
  Dim iRow As Integer, iCol As Integer, iSplit As Integer
  For Each aTbl In ActiveDocument.Tables
    If Not aTbl.Uniform Then
      'Debug.Print "Table size: ", aTbl.Rows.Count, aTbl.Columns.Count
      For Each aCell In aTbl.Range.Cells
        'Debug.Print aCell.RowIndex, aCell.ColumnIndex
        If aCell.RowIndex = aTbl.Rows.Count Then Exit For
        Set aRng = aCell.Range
        aRng.Select
        Selection.MoveDown Unit:=wdLine, Count:=1
        If Selection.Information(wdWithInTable) Then
          iSplit = Selection.Cells(1).RowIndex - aRng.Cells(1).RowIndex
        Else
          iSplit = aTbl.Rows.Count - aRng.Cells(1).RowIndex + 1
        End If
        If iSplit > 1 Then aCell.Split NumRows:=iSplit
      Next aCell
    End If
  Next aTbl
End Sub