Sub Spliting()
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim wdTable As Object
    
    Set wdApp = CreateObject("Word.Application")
    Set wdDoc = wdApp.Documents.Open("path_to_word_document.docx")
    
    For Each wdTable In wdDoc.Tables
        If wdTable.Rows.Count > 1 Then
            If IsTableTextAndEmptyLastRow(wdTable) And IsTableTextAndEmptyLastRow(wdTable.Next)) Then
                wdDoc.Content.InsertAfter "##"
            End If
        End If
    Next wdTable
    
    wdDoc.Close savechanges:=True
    wdApp.Quit
    
    Set wdTable = Nothing
    Set wdDoc = Nothing
    Set wdApp = Nothing
End Sub

Function IsTableTextAndEmptyLastRow(table As Object) As Boolean
    Dim lastRow As Object
    Dim cell As Object
    
    Set lastRow = table.Rows(table.Rows.Count)
    
    For Each cell In lastRow.Cells
        If cell.Range.Text <> " " Then
            IsTableTextAndEmptyLastRow = False
            Exit Function
        End If
    Next cell
    
    IsTableTextAndEmptyLastRow = True
End Function