Выдернуть данные из word таблиц в файл Excel

[kus_kus]

Нужно обработать автоматом кучу однотипных анкет

Я хочу создать файл excel со след колонками: 1 колонка - имя файла, 2 колонка - ответы А, 3-я - ответы B и т.д

Нашёл кусок VBA

Sub ImportWordTable()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim TableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel

wdFileName = Application.GetOpenFilename("Word files (*.doc),*.doc", , _
"Browse for file containing table to be imported")

If wdFileName = False Then Exit Sub '(user cancelled import file browser)

Set wdDoc = GetObject(wdFileName) 'open Word file

With wdDoc
    TableNo = 3
    With .Tables(TableNo)
        'copy cell contents from Word table cells to Excel cells
        For iRow = 3 To 3
            For iCol = 2 To .Columns.Count
                Cells(1, iCol - 1) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
            Next iCol
        Next iRow
        For iRow = 5 To 5
            For iCol = 2 To .Columns.Count
                Cells(1, iCol + 10) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
            Next iCol
        Next iRow
    End With
End With

Set wdDoc = Nothing

End Sub

Но возникло две проблемы:
1) обрабатывает один файл
2) значения вставляются в отдельные ячейки, а нужно бы в одну

Буду рад подсказкам

[Aleksandr H.]

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

Буду рад подсказкам

надо еще 2 файла: исходный Word, Excel с результатом как получается и как должно получиться

[kus_kus]

Сообщение от Aleksandr H.

надо еще 2 файла: исходный Word, Excel с результатом как получается и как должно получиться

Parser.xlsxm - с макросом, на вкладке before что получается, на вкладке after что нужно.

[Aleksandr H.]

Тестируйте

[kus_kus]

Сообщение от Aleksandr H.

Тестируйте

Работает просто класс! Ещё бы ссылку на файл в название вставить

[Aleksandr H.]

Чего, куда?

[kus_kus]

Сообщение от Aleksandr H.

Чего, куда?

Вот в первой строчке- ссылка на файл исходник

[Aleksandr H.]

не знаю, архив пустой

[kus_kus]

Сообщение от Aleksandr H.

не знаю, архив пустой

Исправил

[Aleksandr H.]

Cells(i, 1) = wdDoc.Name
ActiveSheet.Hyperlinks.Add Cells(i, 1), wdDoc.FullName  '<===ВСТАВИТЬ ЭТУ СТРОКУ В КОД