Hmmm. The complicated bit is working out how many rows to split the merged cells into, and the code below could no doubt be simplified, however the following will work with your examples, but it will not work if there are any horizontally merged cells in the table.
Option Explicit
Sub Macro1()
Dim i As Long, j As Long, k As Long
Dim sData() As Variant
Dim oTable As Table
Dim oCell As Cell
Dim oRng As Range
Dim sText As String
Dim sRow As String
Dim iRow As Long
Dim oColl1 As New Collection
Dim oColl2 As New Collection
Set oTable = ActiveDocument.Tables(1)
With oTable
ReDim sData(1 To .Rows.Count, 1 To .Columns.Count)
Set oCell = .Cell(1, 1)
Do While Not oCell Is Nothing
sData(oCell.RowIndex, oCell.ColumnIndex) = oCell.RowIndex & "," & oCell.ColumnIndex
Set oCell = oCell.Next
Loop
For i = 1 To UBound(sData)
sRow = ""
For j = 1 To UBound(sData, 2)
sRow = sRow & IIf(IsEmpty(sData(i, j)), "X", "A") & "|"
Next j
oColl1.Add sRow
Next i
j = 1
For i = oColl1.Count To 1 Step -1
If Left(oColl1(i), 1) = "X" Then
j = j + 1
k = j
Else
k = j
j = 1
End If
If j = 1 Then oColl2.Add k
Next i
iRow = oTable.Columns(1).Cells.Count
k = iRow
For j = 1 To oColl2.Count
For i = oColl2.Count To 1 Step -iRow
oTable.Columns(1).Cells(k).Split oColl2(j), 1
k = k - 1
Next i
Next j
End With
For i = 2 To oTable.Rows.Count
Set oRng = oTable.Rows(i).Cells(1).Range
oRng.End = oRng.End - 1
If Len(oRng) > 1 Then
sText = oTable.Rows(i).Cells(1).Range.Text
Else
oRng.Text = sText
oRng.Text = Replace(oRng.Text, Chr(13), "")
End If
Next i
lbl_Exit:
Set oColl1 = Nothing
Set oColl2 = Nothing
Set oTable = Nothing
Set oCell = Nothing
Set oRng = Nothing
Exit Sub
End Sub