Option Explicit

Sub fnSplitCellsInNewTableRows()
    Dim oTables As Word.Tables 'all document tables
    Dim oTable As Word.Table ' each document table
    Dim intLenOldLines As LongPtr
    Dim intLenNewLines As LongPtr
    Dim oLeftPars As Word.Paragraphs 'Paragraphs on the left cell
    Dim oRightPars As Word.Paragraphs 'Paragraphs on the right cell
    Dim intRow As LongPtr
    Dim intTable As LongPtr
    Dim intTableRow As LongPtr
    Dim intTableRows As LongPtr
    Dim intTablesCount As LongPtr
    Dim oLeftPar As Word.Paragraph 'unique (left) paragraph to work with
    Dim oRightPar As Word.Paragraph 'unique (right) paragraph to work with
    Dim oTableRange As Word.Range 'used to Find/Replace ^p

    Set oTables = ThisDocument.Tables
    intTablesCount = oTables.Count
    
    For intTable = 1 To intTablesCount
        Set oTable = oTables(intTable)
        If oTable.Columns.Count <> 2 Then
            MsgBox "A table with " & oTable.Columns.Count & " columns was discarded."
            GoTo lblNextTable
        End If
        intTableRows = oTable.Rows.Count
        For intRow = 1 To intTableRows
            intLenOldLines = Len(oTable.Rows(intRow).Cells(1).Range.Text)
            intLenNewLines = Len(VBA.Replace(oTable.Rows(intRow).Cells(1).Range.Text, Chr(13), ""))
            
            'compare the amount of chr(13) ocurrences
            'each one determine a new inner line on the cell text, except for the last one.
            If intLenOldLines > intLenNewLines + 1 Then
                Set oLeftPars = oTable.Rows(intRow).Cells(1).Range.Paragraphs
                Set oRightPars = oTable.Rows(intRow).Cells(2).Range.Paragraphs
                oTable.Rows(intRow).Cells.Split (intLenOldLines - intLenNewLines) + 1, 1

                For intTableRow = oTable.Rows.Count To 2 Step -1
                    Set oLeftPar = oLeftPars(intTableRow - 1)
                    Set oRightPar = oRightPars(intTableRow - 1)
                    oTable.Rows(intTableRow).Cells(1).Range.FormattedText = oLeftPar.Range.FormattedText
                    oTable.Rows(intTableRow).Cells(2).Range.FormattedText = oRightPar.Range.FormattedText

                Next

            End If
            ThisDocument.Save
            oTable.Rows(1).Delete ' the original row
            
            'this piece of code strips out ^p on each new cell
            oTable.Select
            Set oTableRange = oTable.Range
            With oTableRange.Find
                .ClearFormatting
                .Text = "^p"
                With .Replacement
                    .ClearFormatting
                    .Text = ""
                End With
                .Execute Replace:=wdReplaceAll, _
                    Format:=True, MatchCase:=True, _
                    MatchWholeWord:=True
            End With

            ThisDocument.Save
        Next
        
lblNextTable:
    Next
    
    DoEvents
    MsgBox "Done."

End Sub