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