VBA exel: найти текст в файле Word и вставить в Exel

[01234567898]

Доброго времени, форумчане.
У меня возникла проблемка. Мне необходимо макросом в Exel скопировать текст из файла Word. Текст файла примерно такой:
Акт №123
...
Таблица 1
Таблица 2
…
Приложения:
Сертификат качества 1 — 5 листов;
Сертификат качества 2 — 3 листа;
…
Сертификат качества N — 2 листа.

Представитель …..

Текст всегда находится между словами «Приложения:» и «Представитель».
Я научился обращаться к файлу Word, вытягивать в Exel данные из таблиц. А вот с поиском и копированием текста беда. А файлов как всегда +100500.

Sub Test()
Dim myWord As Object, myDoc As Object
Dim Name As String, strText1 As String, strText2 As String
 
Name = ThisWorkbook.Worksheets("Лист1").Range("A1") & ".docx"
 
On Error GoTo Instr
 
Set myWord = GetObject(, "Word.Application")
Set myDoc = myWord.Documents(Name)
 
With myDoc.Range
strText1 = «Приложения:»
strText2 = «Представитель»
????????????????????
End With
 
ThisWorkbook.Worksheets("Лист1").Range("A2").Select
ActiveCell.Paste
 
End Sub
 
Instr:
    MsgBox "Произошла ошибка: " & Err.Description
End Sub

Прошу Вас помочь с макросом.

[shanemac51]

Сообщение от 01234567898

Прошу Вас помочь с макросом.

например так, хотя не ясно, что может быть между опорными словами

    Sub Test240514mm()
Dim myWord As Object, myDoc As Object
Dim sName As String, strText1 As String, strText2 As String

'' для отладки немного изменяю имя
sName = "c:\temp\" & ThisWorkbook.Worksheets("Лист2").Range("A1") & ".docx"
 On Error Resume Next
 Set myWord = GetObject(, "Word.Application")
 If Err.Number <> 0 Then
''
Set myWord = CreateObject("Word.Application")
Err.Clear
End If
On Error GoTo Instr

Set myDoc = myWord.Documents.Open(sName)
Dim j1, j2, stext
With myDoc.Range
strText1 = "Приложения:"
strText2 = "Представитель "
stext = .Text
'???????=??????????=???

j1 = InStr(stext, strText1)
j2 = InStr(stext, strText2)
Debug.Print Now, j1, j2, sName
If j1 > 0 And j1 < j2 Then
j1 = j1 + Len(strText1)
'MsgBox
Debug.Print Mid(stext, j1, j2 - j1 - 1)

 ThisWorkbook.Worksheets("Лист2").Range("b1") = Mid(stext, j1, j2 - j1 - 1)
'ThisWorkbook.Worksheets("Лист2").Range("b1").Select
'ActiveCell.Paste
myDoc.Close False
myWord.Quit False
End If
End With
Exit Sub
 
Instr:
Debug.Print Err.Number, Err.Description
'MsgBox "Произошла ошибка: " & Err.Description
End Sub