Extract word tables (multiple files) into excel using VBA

Copy this to a standard module.

Option Explicit

Sub ImportWordTable()
Dim WS As Worksheet
Dim A As Long, B As Long
Dim NextRow As Long
Dim FN As String
Dim CellData As String
Dim WordPath As String
Dim wrdApp As Object
Dim wrdDoc As Object

Set WS = ActiveSheet

With WS
    'Determine last row with data and add one.
    NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
    
    'Path to word files.
    WordPath = "C:\Users\Owner\Documents\VBA\ExcelForum\1055705"
    
    FN = Dir(WordPath & "\*.doc?")
    
    If FN <> "" Then
        On Error Resume Next

       ' Get existing instance of Word if it exists.
       Set wrdApp = GetObject(, "Word.Application")
    
       If Err <> 0 Then
          ' If GetObject fails, then use CreateObject instead.
            Set wrdApp = CreateObject("word.application")
        End If
        
        On Error GoTo 0
        'Test for wrdApp existance.
        If Not wrdApp Is Nothing Then
            Do
                'Open the work doc.
                Set wrdDoc = wrdApp.documents.Open(WordPath & "\" & FN)
                
                'Iterate the Word tables, row 1 to 20.
                For A = 1 To wrdDoc.Tables(1).Rows.Count
                    'Column Counter for Excel sheet.
                    B = B + 1
                    'Assign value in Word Table to a variable.
                    CellData = wrdDoc.Tables(1).Cell(B, 2).Range.Text
                    'Strip off Word table cell markers and assign to Excel sheet.
                    WS.Cells(NextRow, B) = Left(CellData, Len(CellData) - 2)
                Next
                'Add filename to sheet.
                WS.Cells(NextRow, B + 1) = FN
                
                'Close Word document, do not save changes.
                wrdDoc.Close False
                
                'Increment nextrow and clear Excel column counter.
                NextRow = NextRow + 1: B = 0
                FN = Dir
            Loop Until FN = ""
        End If
    End If
End With
Set wrdDoc = Nothing
Set wrdApp = Nothing

End Sub

Sure. Details, please.

So, you want Word Table 1 on Excel Sheet1, Word Table 2 on Excel Sheet2?

I changed it up a little in that you browse for a file location and select the files you want to process. It's been my experience to only select 50-100 files to work on at a time. Keeps Word from bogging things down.

Also, after I created a few extra files for testing, the first name and surname get separated on the Excel sheet due to the row order verses column order.

The way it's written now, it can handle tables that have different column counts.

Hope this helps!

Option Explicit

Sub ImportWordTable()
Dim WS As Worksheet
Dim A As Long, B As Long
Dim I As Long, J As Long
Dim xlCol As Long
Dim NextRow As Long
Dim FN As Variant
Dim CellData As String
Dim WordPath As String
Dim wrdApp As Object
Dim wrdDoc As Object

 On Error Resume Next

' Get existing instance of Word if it exists.
Set wrdApp = GetObject(, "Word.Application")

If Err <> 0 Then
   ' If GetObject fails, then use CreateObject instead.
     Set wrdApp = CreateObject("word.application")
End If
 
 On Error GoTo 0

'Path to word files.
'Use this if you want Excel to always browse for files at a certain location.
'ChDir "C:\Users\Owner\Documents\VBA\ExcelForum\"
FN = Application.GetOpenFilename("Word Files (*.doc), *.doc", _
    , "Navigate to folder containing Word Files", , True)

Set WS = Worksheets(1)
    With WS
        'Determine last row with data and add one.
        NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1

    For J = 1 To UBound(FN)
        'Test for wrdApp existance.
        If Not wrdApp Is Nothing Then
            'Open the work doc.
            Set wrdDoc = wrdApp.Documents.Open(FN(J))

            For I = 1 To wrdDoc.tables.Count
                'Iterate the Word tables, row by row
                For A = 2 To wrdDoc.tables(I).Rows.Count Step 2
                   'Column Counter for Excel sheet.
                    For B = 1 To wrdDoc.tables(I).Columns.Count
                        'Assign value in Word Table to a variable.
                        CellData = wrdDoc.tables(I).Cell(A, B).Range.Text
                        'Strip off Word table cell markers and assign to Excel sheet.
                        xlCol = xlCol + 1 'Excel Column Counter
                        WS.Cells(NextRow, xlCol) = Left(CellData, Len(CellData) - 2)
                    Next
                Next
            Next 'Next Table
            
            'Add filename to sheet.
            WS.Cells(NextRow, xlCol + 1) = FN

            'Close Word document, do not save changes.
            wrdDoc.Close False
            
            'Increment nextrow and clear Excel column counter.
            NextRow = NextRow + 1: xlCol = 0
        End If
    Next
End With
Set wrdDoc = Nothing
Set wrdApp = Nothing

End Sub

It's probably an uneven row count. Change this line from

For A = 2 To wrdDoc.tables(I).Rows.Count Step 2

to

For A = 1 To wrdDoc.tables(I).Rows.Count

It will import the headers as well, but at least you'll have your data.

Can you send me the offending file? My username @ google mail

OK, give this a go.

Option Explicit

Sub ImportWordTable()
Dim WS As Worksheet
Dim A As Long, B As Long
Dim I As Long, J As Long
Dim xlCol As Long
Dim NextRow As Long
Dim FN As Variant
Dim CellData As Variant ' String
Dim WordPath As String
Dim wrdApp As Object
Dim wrdDoc As Object

 On Error Resume Next

' Get existing instance of Word if it exists.
Set wrdApp = GetObject(, "Word.Application")

If Err <> 0 Then
   ' If GetObject fails, then use CreateObject instead.
     Set wrdApp = CreateObject("word.application")
End If
 
 On Error GoTo 0

'Path to word files.
'Use this if you want Excel to always browse for files at a certain location.
'ChDir "C:\Users\Owner\Documents\VBA\ExcelForum\"
FN = Application.GetOpenFilename("Word Files (*.doc?), *.doc?", _
    , "Navigate to folder containing Word Files", , True)
If FN = False Then GoTo TheEnd

Set WS = Worksheets(1)
    With WS
        'Determine last row with data and add one.
        NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1

    For J = 1 To UBound(FN)
        'Test for wrdApp existance.
        If Not wrdApp Is Nothing Then
            'Open the work doc.
            Set wrdDoc = wrdApp.Documents.Open(FN(J))

            For I = 1 To wrdDoc.tables.Count
                    For Each CellData In wrdDoc.tables(I).Range.Cells
                        xlCol = xlCol + 1 'Excel Column Counter
                        'Strip off Word table cell markers and assign to Excel sheet.
                        WS.Cells(NextRow, xlCol) = Left(CellData.Range.Text, _
                            Len(CellData.Range.Text) - 2)
                    Next
            Next 'Next Table
            
            'Add filename to sheet.
            WS.Cells(NextRow, xlCol + 1) = FN(J)

            'Close Word document, do not save changes.
            wrdDoc.Close False
            
            'Increment nextrow and clear Excel column counter.
            NextRow = NextRow + 1: xlCol = 0
        End If
    Next
End With
TheEnd:
Set wrdDoc = Nothing
Set wrdApp = Nothing

End Sub

I'm glad we got it sorted.

Cheers!

Originally Posted by 10degrees

When I run this I receive an error as follows:
"run-time error 13 - type mismatch"

Care to share with us where the error occurs?

Try this line instead

If Not IsArray(FN) then GoTo TheEnd

javedchemist2245 welcome to the forum

Unfortunately your post does not comply with Rule 4 of our Forum RULES. Do not post a question in the thread of another member -- start your own thread.

If you feel an existing thread is particularly relevant to your need, provide a link to the other thread in your new thread.

Old threads are often only monitored by the original participants. New threads not only open you up to all possible participants again, they typically get faster response, too.

Glad my efforts are still helping people.

Hi Tinbendr,

Will you be able to modify your code to accommodate my request given below?

https://www.excelforum.com/excel-pro...ml#post5943711