title: Importing Word Tables to Excel Based on Content
body: <p>I'm having trouble grabbing only the tables I need into Excel. The Word Documents I'm working with consist of various tables but only the ones with certain key words need to be put into excel. </p>
  
  <p>The code loops through the folder creating a worksheet for each file, but when it comes to searching the table for the key phrase, I receive an error in line 28.</p>
  
  <p>I'm new to this, so any suggestions would be appreciated</p>
  
  <pre><code>Sub FormatWordTables()
  
  Dim WB As Workbook
  Set WB = ThisWorkbook
  Dim BOM As Worksheet
  Set BOM = WB.Sheets("BoM")
  lastBOM = BOM.Range("B" &amp; 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 &lt;&gt; ""
  ActiveWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = file
  Dim wdDoc As Object
  Set wdDoc = GetObject("C:\folder\" &amp; 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 &lt;&gt; 0 Then
  
              For iRow = 1 To .Rows.Count
                 'find the last empty row in the current worksheet
                  nextRow = ThisWorkbook.ActiveSheet.Range("a" _
                      &amp; 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
  </code></pre>