Macro to export MS Word tables to Excel sheets

Answer taken from: http://www.mrexcel.com/forum/showthread.php?t=36875

Here is some code that reads a table from Word into the active worksheet of Excel. It prompts you for the word document as well as the table number if Word contains more than one table.

Sub ImportWordTable()Dim wdDoc As ObjectDim wdFileName As VariantDim TableNo As Integer 'table number in WordDim iRow As Long 'row index in ExcelDim iCol As Integer 'column index in ExcelwdFileName = 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 fileWith wdDoc    TableNo = 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 table number of table to import", "Import Word Table", "1")    End If    With .tables(TableNo)        'copy cell contents from Word table cells to Excel cells        For iRow = 1 To .Rows.Count            For iCol = 1 To .Columns.Count                Cells(iRow, iCol) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)            Next iCol        Next iRow    End WithEnd WithSet wdDoc = NothingEnd Sub

This macro should be inserted into Excel (not Word) and put into a standard macro module rather than into the worksheet or workbook event code modules. To do this, go to the VBA (keyboard Alt-TMV), insert a macro module (Alt-IM), and paste the code into the code pane. Run the macro from the Excel interface as you would any other (Alt-TMM).

If your document contains many tables, as would be the case if your 100+ page table is actually a separate table on each page, this code could easily be modified to read all the tables. But for now I am hoping it is all one continuous table and will not require any modification.

Keep Excelling.

Damon

VBAexpert Excel Consulting(My other life: http://damonostrander.com )

I changed this one with an addition to loop through all tables (starting from the chosen table):

Option ExplicitSub ImportWordTable()Dim wdDoc As ObjectDim wdFileName As VariantDim tableNo As Integer 'table number in WordDim iRow As Long 'row index in ExcelDim iCol As Integer 'column index in ExcelDim resultRow As LongDim tableStart As IntegerDim tableTot As IntegerOn Error Resume NextActiveSheet.Range("A:AZ").ClearContentswdFileName = 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 fileWith 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 to start from", "Import Word Table", "1")    End If    resultRow = 4    For tableStart = 1 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                    Cells(resultRow, iCol) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)                Next iCol                resultRow = resultRow + 1            Next iRow        End With        resultRow = resultRow + 1    Next tableStartEnd WithEnd Sub

Next trick: working out how to extract a table within a table from Word... and do I really want to?

TC

Thank you so much Damon and @Tim

I modified it to open docx files, moved a worksheet clear line after checking for escape by user.

Here is the final code:

Option ExplicitSub ImportWordTable()Dim wdDoc As ObjectDim wdFileName As VariantDim tableNo As Integer      'table number in WordDim iRow As Long            'row index in ExcelDim iCol As Integer         'column index in ExcelDim resultRow As LongDim tableStart As IntegerDim tableTot As IntegerOn Error Resume NextwdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _"Browse for file containing table to be imported")If wdFileName = False Then Exit Sub '(user cancelled import file browser)ActiveSheet.Range("A:AZ").ClearContentsSet wdDoc = GetObject(wdFileName) 'open Word fileWith 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 to start from", "Import Word Table", "1")    End If    resultRow = 4    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                    Cells(resultRow, iCol) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)                Next iCol                resultRow = resultRow + 1            Next iRow        End With        resultRow = resultRow + 1    Next tableStartEnd WithEnd Sub