Importing Tables From Word Into Excel Spreadsheet Cells

[Ealcmhar]

Hi,

I'm trying to copy the data contained within tables in a Word document (*.docm) and export it into Excel, however I seem to have no success.

I've tried using this code:
[vba]Sub importwordtoexcel()

'Import all tables to a single sheet
Dim wdDoc As Object
Dim wdFileName As Variant
Dim TableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Word
Dim jRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
wdFileName = Application.GetOpenFilename("Word files (*.docm),*.docm", , _
"Browse for file containing table to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
With wdDoc
If wdDoc.Tables.Count = 0 Then
MsgBox "This document contains no tables", _
vbExclamation, "Import Word Table"
Else
jRow = 0
For TableNo = 1 To wdDoc.Tables.Count
With .Tables(TableNo)
'copy cell contents from Word table cells to Excel cells
For iRow = 1 To .Rows.Count
jRow = jRow + 1
For iCol = 1 To .Columns.Count
On Error Resume Next
Sheets("Teams").Cells(jRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
On Error GoTo 0
Next iCol
Next iRow
End With
jRow = jRow + 1
Next TableNo
End If
End With
Set wdDoc = Nothing
End Sub
[/vba]
however have had no success in producing results. I copied the code from another thread (dubbed "export word tables into excel") and inserted it into VBA under "Modules", and haven't encountered any errors in running it (I can choose to open a document with tables), however nothing is inserted into the active speadsheet.

Any assistance would be happily appreciated.

[Tinbendr]

Comment out the 'On error Resume Next' and see what error it's generating.

[snb]

- adapt the file's fullname

[vba]Sub snb()
With GetObject("G:\OF\__tabel kopie in Excel.docm")
if.tables.count>0 Then
.tables(1).Range.Copy
ThisWorkbook.Sheets(1).Paste ThisWorkbook.Sheets(1).Cells(1)
End if
.Close 0
End With
End Sub[/vba]

[Ealcmhar]

Thanks for the quick responses.

@ Tinbendr
When I commented out 'On error Resume Next'', I received the following error message:
[VBA]Run-time error '9':

Subscript out of range[/VBA]

@ snb
Is the sub intended to be used intact, or do I replace the included file address ("G:\OF\__tabel kopie in Excel.docm") with that of the word document I'd like to extract the table(s) from? I tried replacing the file address with that of the word document with tables in it, although received the following message:
[VBA]Run-time error:

File name or class name not found during Automation operation[/VBA]

[snb]

Like I indicated you have to fill in the full path & name of your Word file.

[Tinbendr]

I tried your code on some word tables I have and it ran fine.

Run it again and hover over each side of the statement to determine if the error is on the Excel side or Word side.

SNB's code is indicating to pull the whole table in at once instead of iterating each cell.

[Ealcmhar]

@ snb
Ah, I've managed to get the code working, however it only imported the second table the world document possessed (it has two, one being a single cell, the other being a 2*8 cell table); would it be possible to extract both tables (say, listing the first table above the second table)?

@Tinbendr
I tried tinkering around a little with the code that I posted up, changing for instance the count (1) in:
[VBA] For TableNo = 1 To wdDoc.tables.Count[/VBA]
to '0', although VBA claimed that no such table existed.
I also tried modifying "Teams" in the following line:
[VBA]Sheets("Teams").Cells(jRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)[/VBA]
to say 'Sheet2' (considering that was the only sheet that I had opened at the time), and it managed to import the contents of the first table (the single-celled one), however nothing of the second.

[snb]

Do not talk about 'first' table or 'second' table.
The index has only to do with succession/priority.

[VBA]Sub snb()
With GetObject("G:\OF\__tabel kopie in Excel.docm")
for each tb in .tables
tb.Range.Copy
ThisWorkbook.Sheets(1).Paste ThisWorkbook.Sheets(1).Cells(rows.count,1).end(xlup).offset(2)
next
.Close 0
End With
End Sub [/VBA]