Копирование данных из одной таблицы в другую

Sub Procedure_1()
    
    'Здесь нужно указать имя документа, в котором ищем и из которого берём данные.
    Const sSourcePath As String = "tabl2.doc"
    
    Dim lFirstRow As Long
    Dim lLastRow As Long
    Dim lRowsCount As Long
    Dim i As Long, j As Long
    Dim lTableRowsCount As Long
    Dim sArray_1(1 To 2) As String
    Dim sArray_2() As String
    Dim sCellText_1 As String, sCellText_2 As String
    Dim lTargetRowNumber As Long
    Dim docSource As Word.Document
    Dim oTable As Word.Table
    
    'Обращаться к документу-источнику будем через переменную docSource.
    Set docSource = Documents(sSourcePath)
    
    'Ищем в документе-источнике текст из активного документа, где находится курсор.
    With docSource.Content.Find
        '-2 - т.к. в ячейке в конце есть 2 специальных символа:
            '1) знак "Конец ячейки" - его видно, если включён режим
                'отображения непечатаемых символов;
            '2) неизвестный знак, который не видно.
                'Порядковый номер в таблице ANSI: 7
        .Text = Left(Selection.Cells(1).Range.Text, Len(Selection.Cells(1).Range.Text) - 2)
        'Если не найдено, то выходим из кода.
        If .Execute = False Then
            Exit Sub
        'Иначе, запоминаем номер строки, где было найден текст.
        Else
        
            'Parent - это фрагмент документа, где находится найденный текст.
            'Записываем номер строки, где был найден текст.
            lFirstRow = .Parent.Cells(1).RowIndex
            
            'Обращаться к таблице будем через переменную.
            Set oTable = .Parent.Tables(1)
            
        End If
        
    End With
    
'---------------------------------------------------------------------------------------------------
    '1. Определяем, с какой по какую строку нужно двигаться.
    
    'Записываем количество строк в таблице.
    'Чтобы при движении вниз, узнать, что достигнут конец таблицы.
    lTableRowsCount = oTable.Rows.Count
    
    'Определение номера последней строки.
    lLastRow = lFirstRow
    
    'Смотрим, не является ли текущая строка последней в таблице.
    If lLastRow = lTableRowsCount Then
        GoTo metka
    End If
    
    'Анализируем остальные строки.
    lLastRow = lLastRow + 1
    Do
        
        'Проверяем, не закончилась ли объединённая ячейка в первом столбце.
        'Если обращаться к ячейке, которой нет, то будет ошибка.
        'On Error Resume Next - позволяет продолжить код при возникновении ошибки.
        On Error Resume Next
        
            If oTable.Cell(lLastRow, 1) Is Nothing Then
            Else
                lLastRow = lLastRow - 1
                GoTo metka
            End If
        
        'On Error GoTo 0 - отменяет действия On Error Resume Next
        On Error GoTo 0
        
        'Смотрим, есть ли текст в 4 столбце.
        'Characters.Count = 1 - это знак "Конец ячейки".
        If oTable.Cell(lLastRow, 4).Range.Characters.Count = 1 Then
            lLastRow = lLastRow - 1
            GoTo metka
        End If
        
        'Смотрим, не является ли текущая строка последней в таблице.
        If lLastRow = lTableRowsCount Then
            GoTo metka
        End If
        
        'Переход к следующей строке.
        lLastRow = lLastRow + 1
        
    Loop
    
metka:
    
    'Определяем сколько строк нужно взять.
    lRowsCount = lLastRow - lFirstRow + 1
    
    
'---------------------------------------------------------------------------------------------------
    '2. Поместим данные в массивы, чтобы проще было код написать.
    
    'Чтобы проще ориентироваться в коде, данные
    'из ячеек помещаем в переменные.
    sCellText_1 = oTable.Cell(lFirstRow, 3).Range.Text
    sCellText_2 = oTable.Cell(lFirstRow, 6).Range.Text
    'Убираем лишние символы.
    sCellText_1 = Left(sCellText_1, Len(sCellText_1) - 2)
    sCellText_2 = Left(sCellText_2, Len(sCellText_2) - 2)
    'Помещаем в массив.
    sArray_1(1) = sCellText_1
    sArray_1(2) = sCellText_2
 
    ReDim sArray_2(1 To lRowsCount, 1 To 2)
    
    j = 1
    
    For i = lFirstRow To lLastRow Step 1
        
        sCellText_1 = oTable.Cell(i, 4).Range.Text
        sCellText_2 = oTable.Cell(i, 5).Range.Text
        
        sCellText_1 = Left(sCellText_1, Len(sCellText_1) - 2)
        sCellText_2 = Left(sCellText_2, Len(sCellText_2) - 2)
        
        sArray_2(j, 1) = sCellText_1 & "/" & sCellText_2
        
        
        sCellText_1 = oTable.Cell(i, 7).Range.Text
        sCellText_2 = oTable.Cell(i, 8).Range.Text
        
        sCellText_1 = Left(sCellText_1, Len(sCellText_1) - 2)
        sCellText_2 = Left(sCellText_2, Len(sCellText_2) - 2)
        
        sArray_2(j, 2) = sCellText_1 & "/" & sCellText_2
        
        j = j + 1
        
    Next i
    
    
'---------------------------------------------------------------------------------------------------
    '3. Переносим данные из массивов в документ-назначение.
    
    'Берём номер строки, где ставили курсор.
    lTargetRowNumber = Selection.Cells(1).RowIndex
    
    'Переносим данные в первый столбец.
    Selection.Tables(1).Cell(lTargetRowNumber + 1, 1).Range.Text = sArray_1(1)
    
    'Переносим данные в третий столбец.
    Selection.Tables(1).Cell(lTargetRowNumber + 1, 3).Range.Text = sArray_1(2)
    
    'Переносим данные во второй и чётвёртый столбцы.
    For i = 1 To UBound(sArray_2, 1) Step 1
        sCellText_1 = Selection.Tables(1).Cell(lTargetRowNumber, 2).Range.Text
        sCellText_2 = Selection.Tables(1).Cell(lTargetRowNumber, 4).Range.Text
        sCellText_1 = Left(sCellText_1, Len(sCellText_1) - 2)
        sCellText_2 = Left(sCellText_2, Len(sCellText_2) - 2)
        Selection.Tables(1).Cell(lTargetRowNumber, 2).Range.Text = _
            sCellText_1 & "/" & sArray_2(i, 1)
        Selection.Tables(1).Cell(lTargetRowNumber, 4).Range.Text = _
            sCellText_2 & "/" & sArray_2(i, 2)
        lTargetRowNumber = lTargetRowNumber + 1
    Next i
    
End Sub