Разделение таблицы на отдельные документы

Sub RowsToDocuments()
    'Переменная для документа, с которым нужно работать.
    Dim oCopyDoc As Document: Set oCopyDoc = ActiveDocument
    Dim i As Long
    'Вспомогательные переменные для упрощения сохранения файла
    'и открытия исходного документа
    Dim sDocFolder As String, sDocFullName As String, sDocExt As String
    'Переменная для диапазонов, подлежащих удалению
    Dim oRangeToDelete As Range
    Dim oTbl As Table
    sDocFullName = oCopyDoc.FullName 'Полный путь к оригинальному документу
    sDocFolder = Mid(sDocFullName, 1, InStrRev(sDocFullName, "\")) 'Путь к папке
    sDocExt = Mid(oCopyDoc.Name, InStrRev(oCopyDoc.Name, ".")) 'Расширение документа
    
    Set oTbl = oCopyDoc.Tables(1)
    
    For i = 2 To oTbl.Rows.Count
        Set oRangeToDelete = oCopyDoc.Range
        Set oTbl = oCopyDoc.Tables(1)
        'Задаём и удаляем диапазон документа, находящийся ниже сохраняемой строки
        If i <> oTbl.Rows.Count Then
            oRangeToDelete.SetRange oTbl.Rows(i + 1).Range.Start, oTbl.Range.End
            oRangeToDelete.Select
            oRangeToDelete.Rows.Delete
        End If
        If i <> 2 Then
            Set oTbl = oCopyDoc.Tables(1)
            'Задаём и удаляем диапазон документа, находящийся выше сохраняемой строки, но без заголовка таблицы
            oRangeToDelete.SetRange oTbl.Rows(i).Range.Start, oTbl.Rows(1).Range.End
            oRangeToDelete.Select
            oRangeToDelete.Rows.Delete
        End If
        'Сохраняем документ под новым именем
        oCopyDoc.SaveAs2 FileName:=sDocFolder & "Строка " & i - 1 & sDocExt, AddToRecentFiles:=False
        'Закрываем документ
        oCopyDoc.Close SaveChanges:=False
        'Открываем исходный документ
        Set oCopyDoc = Documents.Open(sDocFullName)
        DoEvents 'Чтобы не зависать :)
    Next i

End Sub