Copy Word tables to Excel

[Loin75]

Hi, the code below has been banding around the internet and is supposed to help copy Word tables into Excel, but I am having trouble with it as I get the message "The requested member of the collection does not exist".

The display box says I have 26 tables in the chosen word document, where would I like to start. No matter which number i enter, I get the same error.

Can someone please help? Thanks

Sub ImportWordTable2()Dim wdDoc As Object
Dim wdFileName As Variant
Dim tableNo As Integer
Dim iRow As Long
Dim iCol As Integer
Dim resultRow As Long
Dim tableStart As Integer
Dim tableTot As Integer
'On Error Resume Next
'ActiveSheet.Range("A:AZ").ClearContents
wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for O&M Requirement Tables to be Imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
With wdDoc
tableNo = wdDoc.tables.Count
tableTot = wdDoc.tables.Count
If tableNo = 0 Then
MsgBox "This document contains no tables", _
vbExclamation, "Import Word Table"
ElseIf tableNo > 1 Then
tableNo = InputBox("This Word document contains " & tableNo & " tables." _
& vbCrLf & "Enter the table number to start from", "Import Word Table", "1")
End If
resultRow = 2
For tableStart = tableNo To tableTot
With .tables(tableStart)
'copy cell contents from Word table cells to Excel cells
For iRow = 1 To .Rows.Count
For iCol = 1 To .Columns.Count
Worksheets(tableStart).Cells(resultRow, iCol) = _
 WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
Next iCol
resultRow = resultRow + 1
Next iRow
End With
resultRow = 2
Next tableStart
End With
End Sub

 

[Rijnsent]

Hi Loin,
on which line does the error occur (the yellow one in the debugger)? And is there any chance you can provide us with (a sample of) the word document via dropbox/google drive etc link?
Thanks,
Koen

 

[Loin75]

Hi Koen,

Here is a OneDrive link to an example of what our system generates.

https://1drv.ms/f/s!Aqh10lWBdpY7gc1mXp-9p3Py2pyCPg

The reports that get spat out by our system are (quite frankly) crap, convoluted and unmanageable. So we have decided to extract specific tables from the Word report and get it into Excel.

I am currently trying to figure a way for Excel to search for the Header Titles in Word (such as "4. Protection Schedule", or "5. Pensions") and then copy and paste that specific table into excel.

I started with that code, but it doesn't work.

Many thanks

 

[Fennek]

Hi,

the code (in the word-document) copies all tables to excel in one sheet per table. There are still a few shortcommings, but just try it.

Sub test()
Dim iDoc As Document
Set iDoc = ActiveDocument
Ta = iDoc.Content.Tables.Count

With GetObject("c:\tmp\wd_to_xl.xls")
    For i = 1 To Ta
        iDoc.Tables(i).Select
        Selection.Copy
        
            .Windows(1).Visible = True
            .sheets(i).Paste
    Next i
.Close 1
End With

End Sub

regards

 

[Rijnsent]

Hi Loin,
your main issue is a merged cell in the second table... That causes your loop to crash. Like this post states How to cycle through all cells in a word table which is having split cells - Stack Overflow there are two solutions, I chose the less elegant one in my example below. I changed your code a bit to get rid of the withs and selecting a file, which is easier for testing. But basically you could just copy the two error skipping lines to make your solution work. Alternatively you could make a loop through the cells (For Each cl In tbl.Range.Cells -> after that use cl.RowIndex and cl.Columnindex to get the value).

Sub ImportWordTable2()

Dim wdDoc As Object
Dim wdFileName As Variant
Dim tableNo As Integer
Dim iRow As Long
Dim iCol As Integer
Dim resultRow As Long
Dim tableStart As Integer
Dim tableTot As Integer

dirnm = "C:\Users\Castoro\Downloads\"
flnm = "example.docx"
Set wdDoc = GetObject(dirnm & flnm) 'open Word file

tableNo = wdDoc.tables.Count
tableTot = wdDoc.tables.Count

If tableNo = 0 Then
    MsgBox "This document contains no tables", vbExclamation, "Import Word Table"
End If

Set ResSht = Worksheets("Sheet1")
tableNo = 1
resultRow = 2
For tableStart = tableNo To tableTot
    Set tbl = wdDoc.tables(tableStart)
    'copy cell contents from Word table cells to Excel cells
    ResSht.Cells(resultRow, 1).Value = "TABLE " & tableStart & " rows: " & tbl.Rows.Count & " cols: " & tbl.Columns.Count
    resultRow = resultRow + 1
    
    For iRow = 1 To tbl.Rows.Count
        For iCol = 1 To tbl.Columns.Count
            On Error Resume Next
            Debug.Print tbl.cell(iRow, iCol).Range.Text
            ResSht.Cells(resultRow, iCol) = WorksheetFunction.Clean(tbl.cell(iRow, iCol).Range.Text)
            On Error GoTo 0
        Next iCol
        resultRow = resultRow + 1
    Next iRow
    resultRow = resultRow + 1
Next tableStart

End Sub

Hope that helps,

Koen

 

[Loin75]

Thanks Koen, that explains a few things and gives me something to work with. Much appreciated.

And thanks Rennek for your suggestion.

I have stuff to play around with now.

Many thanks

 

[ChrisOK]

Hi Koen,
As of this afternoon, I've encountered this same need: (to extract tables from a Word doc using Excel) and attempted the code above but am getting this error:
"Run-time error 432: File name or class name not found during Automation operation"

Any ideas why this might be occurring?
I created a .xlsm file, pasted this code into the 'ThisWorkbook" area.
Opened up the Word doc that has tables in it and saved the Word doc as "example.docx"..
(some tables do have the top row like Loin's - with a couple merged cells to hold the title of that table)

I even saved the "example.docx" file into the same "Downloads" path you have in your code to try to mirror it as much as possible but got that error..
Hope you or someone knows what I'm doing wrong..?

I've attempted to use an HTML table converter to be able to provide you an example of my table below:
The table sizes vary, but this one's top row has cells that go all the way to the end (even to the other rows beneath it) but the image does not reflect that.. but it's close!

<style type="text/css">
	table.tableizer-table {
		font-size: 12px;
		border: 1px solid #CCC; 
		font-family: Arial, Helvetica, sans-serif;
	} 
	.tableizer-table td {
		padding: 4px;
		margin: 3px;
		border: 1px solid #CCC;
	}
	.tableizer-table th {
		background-color: #104E8B; 
		color: #FFF;
		font-weight: bold;
	}
</style>
<table class="tableizer-table">
<thead><tr class="tableizer-firstrow"><th>SCD-DISCNTL-REC</th><th> </th><th> </th><th> </th><th> </th></tr></thead><tbody>
 <tr><td> </td><td> </td><td> </td><td> </td><td> </td><td> </td><td> </td></tr>
 <tr><td>DOC-ID</td><td>DT-CHG</td><td>DT-EFF</td><td>PROCESS-SEQ</td><td>TBL-CHG-IND</td><td>TRANS-IND-CODE</td><td>TRANS-LR-CODE</td></tr>
 <tr><td> </td><td> </td><td> </td><td> </td><td> </td><td> </td><td> </td></tr>
 <tr><td>D6H</td><td>2003274</td><td>2003274</td><td>001</td><td> </td><td>01</td><td>05</td></tr>
 <tr><td>D6R</td><td>2003274</td><td>2003274</td><td>001</td><td> </td><td>01</td><td>05</td></tr>
</tbody></table>

Thanks greatly!
Chris

 

[Rijnsent]

Hi Chris,
I am not sure what could cause this, but what I can find online: make sure you have the right libraries checked (go to project tools>references and check if the library exists).

Set wdDoc = GetObject(dirnm & flnm) 'open Word file -> might need a reference to the Microsoft Word *** Object Library

If that doesn't work, please post your code here (in brackets: [CODE][/CODE] ).
Cheers,
Koen

 

[ChrisOK]

Thx Koen,
I checked the Object Library and the Word 16.0 was not checked, so I checked it, saved and re-tried - got the same error. Closed out Excel completely, re-opened, verified still checked and tried again - got same error at the exact same point when hitting the F8 to step through it...
The last line that's highlighted before it triggers the error is:

Set wdDoc = GetObject(dirnm & flnm) 'open Word file

Here's the items that are checked:
=Visual Basic For Applications
=Microsoft Excel 16.0 Object Library
=OLE Automation
=Microsoft Office 16.0 Object Library
=Microsoft Word 16.0 Object Library


Here's the code:
Hopefully you'll see something:

Sub ImportWordTable2()

Dim wdDoc As Object
Dim wdFileName As Variant
Dim tableNo As Integer
Dim iRow As Long
Dim iCol As Integer
Dim resultRow As Long
Dim tableStart As Integer
Dim tableTot As Integer

dirnm = "C:\Users\chris.adams\Downloads"
flnm = "example.docx"
Set wdDoc = GetObject(dirnm & flnm) 'open Word file

tableNo = wdDoc.tables.Count
tableTot = wdDoc.tables.Count

If tableNo = 0 Then
    MsgBox "This document contains no tables", vbExclamation, "Import Word Table"
End If

Set ResSht = Worksheets("Sheet1")
tableNo = 1
resultRow = 2
For tableStart = tableNo To tableTot
    Set tbl = wdDoc.tables(tableStart)
    'copy cell contents from Word table cells to Excel cells
    ResSht.Cells(resultRow, 1).Value = "TABLE " & tableStart & " rows: " & tbl.Rows.Count & " cols: " & tbl.Columns.Count
    resultRow = resultRow + 1
    
    For iRow = 1 To tbl.Rows.Count
        For iCol = 1 To tbl.Columns.Count
            On Error Resume Next
            Debug.Print tbl.cell(iRow, iCol).Range.Text
            ResSht.Cells(resultRow, iCol) = WorksheetFunction.Clean(tbl.cell(iRow, iCol).Range.Text)
            On Error GoTo 0
        Next iCol
        resultRow = resultRow + 1
    Next iRow
    resultRow = resultRow + 1
Next tableStart

End Sub

 

[Rijnsent]

Hi Chris,
I think I see the culprit:

dirnm = "C:\Users\chris.adams\Downloads"

'Should end with a \ .....

flnm = "example.docx"
Set wdDoc = GetObject(dirnm & flnm) 'open Word file
'The file that will now be opened is C:\Users\chris.adams\Downloadsexample.docx , which probably doesn't exist

Cheers,

Koen