Автоматический перенос текста при переходе на новую страницу в таблице Word

Sub Дублировать_1_2_ст_при_переносе()
    Dim i%, j%, k%, S$, CellEndPage%, Tabl, Ra As Range, Line1%, Line2%, Line3%, Line4%
    For Each Tabl In ActiveDocument.Tables
        With Tabl
            For i = 1 To .Rows.Count
                .Cell(i, 3).Range.Select
                Selection.Collapse Direction:=wdCollapseStart
                Line1 = Selection.Information(wdFirstCharacterLineNumber)
                .Cell(i, 3).Range.Select
                Selection.End = Selection.End - 1
                Selection.Collapse Direction:=wdCollapseEnd
                Line4 = Selection.Information(wdFirstCharacterLineNumber)
                CellEndPage = Selection.Information(wdActiveEndPageNumber)
                Set Ra = .Cell(i, 3).Range
                Ra.End = Ra.End - 1
                With Ra
                    For j = .Start To .End
                        .Start = j
                        .End = j
                        If .Information(wdActiveEndPageNumber) = CellEndPage Then
                            Line3 = .Information(wdFirstCharacterLineNumber)
                            Exit For
                        Else
                            Line2 = .Information(wdFirstCharacterLineNumber)
                        End If
                    Next
                End With
                Set Ra = .Cell(i, 3).Range
                Ra.End = Ra.Start
                If CellEndPage > Ra.Information(wdActiveEndPageNumber) Then
                    For j = 1 To 2
                        S = .Cell(i, j).Range.Text
                        S = Left(S, Len(S) - 1)
                        While Right(S, 1) = Chr(13) Or Right(S, 1) = Chr(10)
                             S = Left(S, Len(S) - 1)
                        Wend
                        .Cell(i, j).Range.Select
                        Selection.End = Selection.End - 1
                        Selection.TypeText String((Line2 - Line1) / 2, vbCr) & S & String((Line2 - Line1 - 1 + Line4 - Line3) / 2, vbCr) & S
                        ''Do
                        ''    .Cell(i, j).Range.Select
                        ''    Selection.End = Selection.End - 1
                        ''    Selection.Start = Selection.End - 1
                        ''    PointsUp2 = Selection.Information(wdVerticalPositionRelativeToTextBoundary)
                        ''    Selection.Collapse Direction:=wdCollapseEnd
                        ''    Selection.TypeText String(PointsUp2 / 14.3, vbCr) & S
                        ''    Selection.TypeParagraph
                        ''    ActiveDocument.CountNumberedItems
                        ''Loop While Selection.Information(wdActiveEndPageNumber) < CellEndPage
                        ''Selection.TypeText S
                    Next j
                End If
            Next i
        End With
    Next Tabl
End Sub

Sub Дублировать_1_2_ст_при_переносе()
    Dim i%, j%, k%, S$, CellEndPage%, Tabl, Ra As Range, Line1%, Line2%, Line3%, Line4%
    For Each Tabl In ActiveDocument.Tables ' Перебор всех таблиц в активном документе
        With Tabl   ' Работаем через символ . с очередной таблицей
            For i = 1 To .Rows.Count ' Перебор всех строк таблицы
                .Cell(i, 3).Range.Select  ' Выделяем ячейку в i-той строке столбец 3
                Selection.Collapse Direction:=wdCollapseStart ' Схлопываем выделение к началу
                Line1 = Selection.Information(wdFirstCharacterLineNumber) 'Определяем номер строки документа (не строки таблицы) где находится курсор - начало переносимой на 2 страницы ячейки
                .Cell(i, 3).Range.Select ' Выделяем ячейку в i-той строке столбец 3
                Selection.End = Selection.End - 1 ' Уменьшаем выделение с конца на 1 символ, если этого не делать то при схлопывании к концу мы выйдем за границу таблицы
                Selection.Collapse Direction:=wdCollapseEnd ' Схлопываем выделение к концу (остаемся внутри ячейки)
                Line4 = Selection.Information(wdFirstCharacterLineNumber) 'Определяем номер строки документа - конец переносимой на 2 страницы ячейки
                CellEndPage = Selection.Information(wdActiveEndPageNumber) 'Определяем номер страницы, на которой находится конец переносимой на 2 страницы ячейки
                Set Ra = .Cell(i, 3).Range ' Определяем диапазон,
                Ra.End = Ra.End - 1  ' соответствующий содержанию переносимой ячейки (без символа конца ячейки)
                With Ra
                    For j = .Start To .End ' Перебираем этот диапазон по 1 символу с начала до конца
                        .Start = j
                        .End = j
                        If .Information(wdActiveEndPageNumber) = CellEndPage Then ' Если страница равна CellEndPage, то Ra находится уже на следующей странице
                            Line3 = .Information(wdFirstCharacterLineNumber) ' Первая строка на следующей странице при переносе
                            Exit For ' Выходим из перебора
                        Else ' Если страница не равна CellEndPage, то Ra все еще находимся на предыдущей странице
                            Line2 = .Information(wdFirstCharacterLineNumber) ' последняя строка снизу на предыдущей странице в месте переноса (определяется в предыдущий шаг перед последним шагом перебора)
                        End If
                    Next
                End With
                Set Ra = .Cell(i, 3).Range ' Определяем диапазон, соответствующий содержанию переносимой ячейки
                Ra.End = Ra.Start  ' Схлопываем диапазон к началу
                If CellEndPage > Ra.Information(wdActiveEndPageNumber) Then '  Если найденное ранее CellEndPage > начала диапазона Ra, то ячейка перенесена на 2 страницы
                    For j = 1 To 2 ' Перебор столбцов 1 и 2
                        S = .Cell(i, j).Range.Text ' Запоминаем текст в переменную  S
                        S = Left(S, Len(S) - 1) ' Удаляем символ конца ячейки
                        While Right(S, 1) = Chr(13) Or Right(S, 1) = Chr(10) ' Если с конца знак абзаца или переноса строки
                             S = Left(S, Len(S) - 1) ' Удаляем их все из переменной S
                        Wend
                        .Cell(i, j).Range.Select  ' Выделяем ячейку в i-той строке столбец j
                        Selection.End = Selection.End - 1 'уменьшаем выделение на символа конца ячейки, чтобы выделить только содержимое
                        ' Гвоздь всей программы в 1 строку, заменяем  содержимое ячейки новым:
                        ' String((Line2 - Line1) / 2, vbCr) - Добавляем символы абзаца числом (Line2 - Line1) / 2 спереди текста,
                        ' S - исходный текст
                        ' String((Line2 - Line1 -1) / 2, vbCr) Добавляем символы абзаца числом (Line2 - Line1- 1) / 2 после текста, здесь мы примерно восстановили то, что уже было
                        ' String((Line4 - Line3) / 2, vbCr) Добавляем символы абзаца числом (Line4 - Line3) / 2 уже в начале следующей страницы
                        ' S - еще раз исходный текст
                        Selection.TypeText String((Line2 - Line1) / 2, vbCr) & S & String((Line2 - Line1 - 1 + Line4 - Line3) / 2, vbCr) & S
                    Next j
                End If
            Next i
        End With
    Next Tabl
End Sub