Импорт таблиц Word в Excel на основе содержимого

Question

У меня возникли проблемы с захватом только таблиц, которые мне нужны в Excel. Документы Word, с которыми я работаю, состоят из разных таблиц, но только те, у кого есть определенные ключевые слова, нужно преуспеть.

код перебирает папки, создавая таблицу для каждого файла, но когда дело доходит до поиска в таблице для ключевой фразы, я получаю сообщение об ошибке в строке 28.

Я новичок в этом, так любые предложения будут оценены

Sub FormatWordTables() 

Dim WB As Workbook 
Set WB = ThisWorkbook 
Dim BOM As Worksheet 
Set BOM = WB.Sheets("BoM") 
lastBOM = BOM.Range("B" & Rows.Count).End(xlUp).Row 

Dim file As String 
file = Dir("C:\folder\*.docx") 

' create worksheet with the name of the file 
Do While file <> "" 
ActiveWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = file 
Dim wdDoc As Object 
Set wdDoc = GetObject("C:\folder\" & file) 

Dim TableNo As Long 'table number in Word 
Dim iRow As Long 'row index in Excel 
Dim iCol As Long 'column index in Excel 
Dim tblCount As Long 
With wdDoc 
    TableNo = wdDoc.tables.Count 
    For tblCount = 1 To wdDoc.tables.Count 
     ' search through tables in Doc for specific text 
     With .tables(tblCount) 
     Dim STable As Object 
     Set STable = .Range(Start:=wdDoc.tables(tblCount).Cell(1, 1).Range.Start, _ 
     End:=wdDoc.tables(tblCount).Cell(2, .Columns.Count).Range.End) 
     SText = "Identifying Text" 
     Dim Match As Range 
     Set Match = Nothing 
     Set Match = STable.Find(What:=SText) 

     ' if text is found copy data to excel sheet 
     If Match <> 0 Then 

      For iRow = 1 To .Rows.Count 
       'find the last empty row in the current worksheet 
       nextRow = ThisWorkbook.ActiveSheet.Range("a" _ 
        & Rows.Count).End(xlUp).Row + 1 
       For iCol = 1 To .Columns.Count 
       .Cell(iRow, iCol).Range.Copy 
       ThisWorkbook.ActiveSheet.Cells(nextRow, iCol).Activate 
       ThisWorkbook.ActiveSheet.Paste 
       Next iCol 
      Next iRow 
     End If 
     End With 
    Next tblCount 
End With 
Set wdDoc = Nothing 

file = Dir() 
Loop 

End Sub 

Answer 1

Line 16 отсутствует разделитель папок и должно быть:

Set wdDoc = GetObject("C:\folder\" & file) 

Edit: Так вы только ищет текст в первых двух строках таблицы. Изменение вашего кода, как показано ниже, должно работать на вас.

With .tables(tblCount) 
Dim STable As Range 
Set STable = .Range 
STable.MoveEnd wdRow, -(.Rows.Count - 2)