Macro to Import Multiple Word Tables Into Excel Worksheet

[atom2]

As the title says I am trying to take multiple tables from a Word document and import them into an Excel worksheet. Currently I have found two versions that when combined, could yield what I am looking for. The first one imports the table's data from Word, but does not maintain formatting of the table (font, colors, rows/columns etc.):

Option Explicit
Sub ImportWordTable()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim tableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
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 (*.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
    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 tableStart
End With
End Sub

The next code maintains formatting, but only imports/pastes one table:

Sub Sample()
    Dim oWordApp As Object, oWordDoc As Object
    Dim FlName As String
    Dim tbl As Object

    FlName = Application.GetOpenFilename("Word files (*.Doc*),*.Doc*", , _
             "Browse for file containing table to be imported")

    '~~> Establish an Word application object
    On Error Resume Next
    Set oWordApp = GetObject(, "Word.Application")

    If Err.Number <> 0 Then
        Set oWordApp = CreateObject("Word.Application")
    End If
    Err.Clear
    On Error GoTo 0

    oWordApp.Visible = True

    Set oWordDoc = oWordApp.Documents.Open(FlName)

    Set tbl = oWordDoc.Tables(1)

    '~~> Excel Objects
    Dim wb As Workbook, ws As Worksheet

    Set wb = Workbooks.Open("C:\Temp\Documents Page XX_US-VC Combo Template.xlsx")

    Set ws = wb.Sheets(1)

    tbl.Range.Copy

    ws.Range("A1").Activate

    ws.Paste
End Sub

For the second one, I do not like the fact that it is calling a specific Workbook to paste into. If I could somehow maintain the ability to import/past multiple tables while keeping formatting that would be perfect. An extra bonus would be to import each table within the Word document into individual Worksheets in Excel. I am also using Office 2010. Thanks! References: http://www.mrexcel.com/forum/excel-questions/36875-word-table-into-excel-worksheet.html vba - How to preserve source formatting while copying data from word table to excel sheet using VB macro? - Stack Overflow

 

[atom2]

I'm hoping its as easy as combining the two somehow. Or at least taking the needed parts from one another.

 

[atom2]

Sorry forgot to mention maintaining of Word tables.

 

[atom2]

Anyone?

Thanks

 

[atom2]

This is the closest one that I have come across so far:

[FONT=Times New Roman][COLOR=#000000]Option Explicit



Sub Sample()

    Dim oWordApp As Object, oWordDoc As Object

    Dim FlName As String

    Dim tbl As Object

    Dim A As Long

    Dim TblCount As Long

    '~~> Excel Objects

    Dim WB As Workbook, WS As Worksheet



    FlName = Application.GetOpenFilename("Word files
(*.Doc*),*.Doc*", , _

            
"Browse for file containing table to be imported")



    '~~> Establish an Word application object

    On Error Resume Next

    Set oWordApp = GetObject(, "Word.Application")



    If Err.Number <> 0 Then

        Set oWordApp =
CreateObject("Word.Application")

    End If

    Err.Clear

    On Error GoTo 0



    oWordApp.Visible = True



    Set oWordDoc = oWordApp.Documents.Open(FlName)



    TblCount = oWordDoc.tables.Count



    Set WB = Workbooks.Open("C:\Temp\Documents Page
XX_US-VC Combo Template.xlsx")

    

    If TblCount > 3 Then

        For A = 4 To TblCount

           
WB.Worksheets.Add after:=Worksheets(WB.Worksheets.Count)

        Next

    End If

    

    A = 1

    

    For Each tbl In oWordDoc.tables



        tbl.Range.Copy

    

        With WB.Worksheets(A)

           
.Range("A1").PasteSpecial xlPasteAll

            A = A + 1

        End With

    Next

oWordDoc.Close False

oWordApp.Quit

Set oWordDoc = Nothing

Set oWordApp = Nothing

End Sub[/COLOR][/FONT]

Only thing wrong is that its converting the tables to an image and its referencing a separate workbook.

 

[atom2]

I am still trying to figure this thing out. Thanks