Получить определенные значения из документа word макросом - VBA

Формулировка задачи:

Здравствуйте! Подскажите, пожалуйста, можно ли макросом произвести поиск по ключевому слову в документах Word и на основе этого вытащить определенные данные в таблицу Excel или ворд? И как это сделать? Ситуация: Есть 4 года и 65 компаний. И есть соответственно 260 отчетов, названных "Компания_год". В отчетах содержится информация о акционерах компании и их долях. Во всех отчетах необходимый раздел (да и все разделы) называется одинаково. Нужно макросом найти этот раздел и вытащить из него пары: "название - доля1, доля2" в отдельный файл. Название идет после фразы: "Полное фирменное наименование: ", доли после "Доля участия лица в уставном капитале эмитента, %: " и "Доля принадлежащих лицу обыкновенных акций эмитента, %: ". В идеале должна получится таблица вида (заголовки любые), всего будет 4 листа, каждый для своего года: Компания1: Акционер1 доля1 доля2 акционер2 доля1 доля2 акционер3 доля1 доля2 Компания2: Акционер1 доля1 доля2 акционер2 доля1 доля2 акционер3 доля1 доля2 Прикрепляю файл-пример с разделом отчета, из которого надо вытащить данные Собственно, вопрос: возможно ли это? и, возможно, кто-то писал подобное и готов поделиться? Отношения с vba: с языком практически не знакома, но могу читать код и "собирать" из разных макросов, чуть переделывать под себя (но только внутри excel или word). С макросами экспорта из word в excel или наоборот не сталкивалась никогда. Поиск пока выдает только "из excel в word", а не наоборот. Спасибо!

Решение задачи: «Получить определенные значения из документа word макросом»

textual
                            Листинг программы 
                        
 
                            
                        
Sub Akzioners()
    Dim b(), i&, j&, txt$, n&, k&, rw&
    a = Array("Полное фирменное наименование:", _
        "Доля участия лица в уставном капитале эмитента, %:", _
        "Доля принадлежащих лицу обыкновенных акций эмитента, %:")
    Workbooks.Add
    Set ShExcel = ActiveSheet
    FileDocs = Application.GetOpenFilename(filefilter:="Documents(*.doc;*.docx),*.doc;*.docx", _
                Title:="Выберите файлы компаний с данными акционеров", MultiSelect:=True)
    If Not IsArray(FileDocs) Then Exit Sub
    Application.ScreenUpdating = False
    Set objWord = CreateObject("Word.Application")
    'objWord.Visible = True
    For k = 1 To UBound(FileDocs)
        With objWord.Documents.Open(FileDocs(k))
            txt = .Range.Text
            s = Split(txt, a(0))
            ReDim b(UBound(s), 0 To 2)
            b(0, 0) = .Name
            .Close
        End With
        s = Split(txt, vbCr)
        j = 1
        For n = 0 To UBound(s)
            If InStr(1, s(n), a(i)) <> 0 Then
                b(j, i) = VBA.Trim(Split(s(n), ":")(1))
                i = i + 1
                If i > 2 Then i = 0: j = j + 1
            End If
        Next
        With ShExcel
            rw = IIf(.UsedRange.Rows.Count = 1, 1, .UsedRange.Rows.Count + 1)
            .Cells(rw, 1).Resize(UBound(b, 1) + 1, UBound(b, 2) + 1) = b
        End With
    Next
    Application.ScreenUpdating = True
    objWord.Quit
End Sub