Extract Word header table data to excel (closed word document)

[Yakov on Excel]

I have a table of file paths and file names for closed word documents. Here is an example:

File Path	File Name
Q:\filepathexample\	docexample.doc

In each of my closed documents there are 2 tables in the header. I need to extract the value of cell A1 in table 2 of the header, and paste it into my table in column C.

I would prefer to do this without opening the word document, because I may be running this code for hundreds of entries in my table.

Here's my code so far, I have defined the path and filename as strings, and the code it will loop through my table. I've had a little success with pulling data from tables in the body of the document, but I can't figure out how to access the tables in the header.

Sub wordextract()
    
Dim lRow As Integer   'current row
Dim lLR As Long         ' last row
Dim sPath As String    'file path
Dim sName As String  'file name
Dim tablenum as integer 'table number in word


lLR = Range("A" & Rows.Count).End(xlUp).row
For lRow = 1 To lLR
    sPath = Cells(lRow, "A")
    Bname = Cells(lRow, "B")
    
'this line will paste the value into the correct column and row in my worksheet, but I can't figure out how to grab that cell value from the word doc
    Range("C" & lRow & "").Value = ???
    
Next lRow

End Sub

[Yakov on Excel]

Here is what I have at this point. I still can't figure out how to access the table in the header.

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
Dim lRow As Integer
Dim lLR As Long

'find number of rows in spreadsheet
lLR = Range("A" & Rows.Count).End(xlUp).row


For lRow = 2 To lLR

wdFileName = Cells(lRow, 1)

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

Set wdDoc = GetObject(wdFileName) 'open Word file

With wdDoc
    TableNo = wdDoc.tables.Count
    If TableNo = 0 Then
        Cells(lRow, 2) = "!No Tables"
        On Error Resume Next
    ElseIf TableNo > 1 Then
        TableNo = 1
    End If
    With .tables(TableNo)
        'copy cell contents from Word table cells to Excel cells
        For iRow = lRow To lLR
                Cells(iRow, 2) = WorksheetFunction.Clean(.cell(1, 4).Range.Text)
        Next iRow
    End With
End With

Set wdDoc = Nothing

Next lRow

End Sub

[JieJenn]

Can you attach the word document?

[Yakov on Excel]

OK - I've got it solved, I finally found how to include the section and header as you set the object

Like this:

wdDoc.Sections(1).Headers(1).Range.tables.Count

So now I can pull the cell that I want from the word document, but when I try to run my code for a large list of file paths it only does about first 50, and then 10 or 15 scattered ones after that from my list.

Is there any way to speed my code up? I THINK most of the processing is coming from opening and closing those word files.

Option Explicit

Sub ImportWordTable()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim TableNo As Integer 'table number in Word
Dim desigTableNo As Integer 'designated table that we want to import from
Dim iRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
Dim lRow As Integer 'current row in cycle
Dim lLR As Long 'last row of data in excel sheet
Dim wRow As Integer 'row of word table we want data from
Dim wCol As Integer 'column of word table we want data from
Dim pCol As Integer 'column we want to past info into

'find number of rows in spreadsheet
lLR = Range("A" & Rows.Count).End(xlUp).Row
'set which table we want to pull data from
desigTableNo = Sheets("Search").Cells(2, 3).Value
'set which table row
wRow = Sheets("Search").Cells(3, 3).Value
'set which table column
wCol = Sheets("Search").Cells(4, 3).Value
'set which column we want info to be pasted to
pCol = Sheets("Search").Cells(7, 3).Value

'Code optimizer for much quicker cycle time (see module 1)
Call OptimizeCode_Begin

For lRow = 2 To lLR

wdFileName = Cells(lRow, 1)

On Error Resume Next
Set wdDoc = GetObject(wdFileName) 'open Word file

With wdDoc
    TableNo = wdDoc.Sections(1).Headers(1).Range.tables.Count
    If TableNo = 0 Then
        Cells(lRow, pCol) = "!No Tables"
        On Error Resume Next
    ElseIf TableNo > 1 Then
        TableNo = desigTableNo
    End If
    With .Sections(1).Headers(1).Range.tables(desigTableNo)
        'copy cell contents from Word table cells to Excel cells
        For iRow = lRow To lRow
                Cells(iRow, pCol) = WorksheetFunction.Clean(.cell(wRow, wCol).Range.Text)
        Next iRow
    End With
End With

Set wdDoc = Nothing

Next lRow

'Code optimizer for much quicker cycle time (see module 1)
Call OptimizeCode_End

End Sub