Multiple Tables in MS Word to Excel Rows?

[Aaron757]

I have a 500 page document that has a few hundred small tables. What I would like to do is:

1. Take the content of each table, convert to text delimited by paragraph so I have a column of text based on the cell contents of the entire table.

2. Take that column of text that was produced and import it into a row in excel.

3. Repeat for each table so that by the end of the document, I have a excel sheet with a bunch of rows, each of which represents the entire contents of a single table.

I'll be honest, I'm not a Visual Basic coder, but I do write scripts so I know how this could be done theoretically, I just don't yet have the knowledge to do it in VB and I'm up against a short timeline. Any help?

 

[Aaron757]

Actually what I said above won't work because some of the cells have multi line entries which would make the resulting rows different lengths.

So I just need something that can copy a MS word table cell by cell (exact contents) into a single excel row, then move to the next table/row repetitively.

 

[VoG]

Try this

Sub ImportWordTable3()
'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 (*.doc),*.doc", , _
"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
        Sheets.Add after:=Sheets(Worksheets.Count)
        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
                        ActiveSheet.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

 

[Aaron757]

Hi Peter,

Thanks for this code! Unfortunately it doesn't do what I'm looking for, not by your fault as the code is wonderful, but by my inability to accurately explain what I'm looking for.

If I have two Word tables that contains the following:
a b c d
1 2 3 4

x y z
9 8 7 6 5

I'd like it to be put in excel as two rows:
a b c d 1 2 3 4
x y z 9 8 7 6 5

I'm going to try to take the code you posted which works great and modify it, but if you have suggestions please let me know. Thank you so very much for your help!!!