Разделить таблицу по условию

 Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "MYTHIC"
            .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    Selection.SplitTable
    Selection.InsertBreak Type:=wdPageBreak
    End Sub

Sub mm130829()
Dim j1, j1k, s1, S2
j1k = Word.ActiveDocument.Tables(1).Rows.Count
Do While j1k > 1
j1k = j1k - 1
With Word.ActiveDocument.Tables(1).Rows(j1k).Cells(1)
s1 = UCase(.Range.Text)
S2 = UCase("MYTHIC*")
If s1 Like S2 Then
Debug.Print s1
.Select
Selection.SplitTable
Selection.InsertBreak Type:=wdPageBreak
End If
End With
Loop
End Sub

Sub mm130829() 
Dim j1, j1k, s1, S2 
j1k = Word.ActiveDocument.Tables(1).Rows.Count 
j1=0
Do While j1k > 1 
j1k = j1k - 1 
With Word.ActiveDocument.Tables(1).Rows(j1k).Cells(1) 
s1 = UCase(.Range.Text) 
S2 = UCase("MYTHIC*")
 If s1 Like S2 Then 
Debug.Print s1 
.Select j1=j1+1
Selection.SplitTable 
Selection.InsertBreak Type:=wdPageBreak 
End If 
End With 
Loop
msgbox "найдено " & j1
 End Sub

Sub mm130829_1540()
Dim j1, j1k, s1, S2
j1 = 0
j1k = Word.ActiveDocument.Tables(1).Rows.Count
Do While j1k > 1
j1k = j1k - 1
With Word.ActiveDocument.Tables(1).Rows(j1k).Cells(2)
s1 = UCase(.Range.Text)
S2 = UCase("MYTHIC*")
If s1 Like S2 Then
Debug.Print s1
j1 = j1 + 1
.Select
.Range.Text = ""
Selection.SplitTable
Selection.InsertBreak Type:=wdPageBreak
End If
End With
Loop
MsgBox "find=" & j1
 
End Sub

Sub N_мифических_таблиц()
If ActiveDocument.Tables.Count > 1 Then MsgBox "Уже сработало!": Exit Sub
Const BreakingWord = "MYTHIC" 'содержимое, по которому разбиваем
Dim N, j1k, s
 
j1k = ActiveDocument.Tables(1).Rows.Count
    Do While j1k > 1
    j1k = j1k - 1
        With ActiveDocument.Tables(1).Rows(j1k).Cells(2)
        s = Left(UCase(.Range.Text), Len(BreakingWord))
            
            If Trim(s) = Trim(BreakingWord) Then
'                Debug.Print "В " & j1k & "-й строке слово s = ", s
                N = N + 1
                .Select
                With Selection
                    .SplitTable
                    .Fields.Add Range:=.Range, Text:="seq Таб." 'поле нумерации
                    .HomeKey
                    .Paragraphs.Last.Alignment = wdAlignParagraphRight
                    If j1k > 1 Then .InsertBreak Type:=wdPageBreak
                    'а 1-ю подтаблицу оставляем на месте (на своей странице)
 
                    If j1k = 1 Then .TypeText "Всего подтаблиц: " & N & Chr(13)
                End With
            End If
        End With
    Loop
ActiveDocument.Fields.Update 'обновляет вставленные над таблицами нумера
'MsgBox "В исходной таблице найдено терминаторов (" & BreakingWord & "): " & N
End Sub

Sub SplitTableOnKeyword()
'    Ключевое слово
    Const KEYWORD = "MYTHIC"
'    Переход в начало документа
    Selection.HomeKey wdStory
'    Счётчик разбивок
    Dim cnt As Integer
'    Поиск искомого слова
    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .MatchCase = True
        .MatchWholeWord = True
        .Text = KEYWORD
        While .Execute
            With Selection
'                Если найденное слово находится в таблице
                If .Information(wdWithInTable) Then
                    .SplitTable 'Разбивка таблицы
                    .InsertBreak wdPageBreak 'Вставка разрыв страницы
                    .MoveDown wdLine, 3, wdMove 'Смещение вниз, чтобы продолжить поиск
                    cnt = cnt + 1 'Увеличение счётчика
                End If
            End With
        Wend
    End With
'    Вставка ячейки с количеством разбиений перед первой разбитой таблицей
    Dim par As Paragraph
    Set par = ActiveDocument.Tables(1).Range.Paragraphs.First.Previous
    par.Range.InsertParagraphBefore
    With ActiveDocument.Tables.Add(par.Previous.Range, 1, 1)
        .Columns(1).SetWidth 100, wdAdjustNone
        .Borders.Enable = wdLineStyleSingle
        .Range.Paragraphs.Alignment = wdAlignParagraphCenter
        .Range.Font.Bold = True
        .Range.Text = cnt
    End With
End Sub