Sub Find_Copy_Paste()

Dim myWord As Object, myDoc As Object, myText As Object
Dim lastRow As Long
Dim Name As String
Dim strText1 As String, strText2 As String

Dim strN As String, strK As String 'переменные начала и конца копируемого текста

Name = ThisWorkbook.Worksheets("ID+cert").Range("B2") & ".docx"
strText1 = "Приложения:" '+1 - Начало фрагмента текста
strText2 = "Представитель" '-1 - Конец фрагмента текста

    Set myWord = GetObject(, "Word.Application")
    Set myDoc = myWord.Documents(Name)
    Set myText = myDoc.Range




ThisWorkbook.Worksheets("Листы").Range("A3") = скопированный текст

End Sub

Sub Copy_Paste_Full()

Dim lastRow As Long
Dim Line As Long
Dim NumAct As String, Path As String
Dim objWrdApp As Object
Dim objWrdDoc As Object
Dim lCol As Long, aTbl As Long, i As Long, j As Long, lastRow_1 As Long

lastRow = ThisWorkbook.Worksheets("Акты").Range("A" & Rows.Count).End(xlUp).Row

For Line = 2 To lastRow

NumAct = ThisWorkbook.Worksheets("Акты").Range("A" & Line)
Path = ThisWorkbook.Worksheets("Акты").Range("B" & Line)

'    On Error Resume Next
    Set objWrdApp = GetObject(, "Word.Application")
    If objWrdApp Is Nothing Then
        Set objWrdApp = CreateObject("Word.Application")
        Set objWrdDoc = objWrdApp.Documents.Open(Path)
            objWrdDoc.Activate
            objWrdApp.Visible = True
    End If

    lCol = objWrdDoc.tables.Count

    For aTbl = 2 To lCol - 1
        ReDim arr(1 To objWrdDoc.tables(aTbl).Rows.Count, 1 To objWrdDoc.tables(aTbl).Columns.Count)
            For j = 1 To UBound(arr, 2)
                For i = 2 To UBound(arr, 1)
                    arr(i, j) = Trim(Replace(objWrdDoc.tables(aTbl).cell(i, j).Range.Text, Chr(7), ""))
                Next i
            Next j
        
            lastRow_1 = ThisWorkbook.Worksheets("ID").Range("A" & Rows.Count).End(xlUp).Row
        
            ThisWorkbook.Sheets("ID").Range("A" & lastRow_1 + 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr

        If Range("A" & lastRow_1 + 1) = "" Then
            Range("A" & lastRow_1 + 1).EntireRow.Delete
        End If

    Next aTbl

        GetObject(, "Word.Application").Quit

Next Line

End Sub