Import tables to excel

[vaxo]

Hello Friends, I have this code for extracting word tables to excel sheet, but it loses word format.
Can we adjust this code so that, not losing word format??

Code: Select all

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
    Dim allTables As Collection '<<

    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

    Set allTables = GetTables(wdDoc)  '<<< see function below

    tableNo = allTables.Count
    tableTot = allTables.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 allTables(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 Sub

'extract all tables from Word doc into a collection
Function GetTables(doc As Object) As Collection

    Dim shp As Object, i, tbls As Object
    Dim tbl As Object
    Dim rv As New Collection

    'find tables directly in document
    For Each tbl In doc.Tables
        rv.Add tbl
    Next tbl

    'find tables hosted in shapes
    For i = 1 To doc.Shapes.Count
        On Error Resume Next
        Set tbls = doc.Shapes(i).TextFrame.TextRange.Tables
        On Error GoTo 0
        If Not tbls Is Nothing Then
            For Each tbl In tbls
                rv.Add tbl
            Next tbl
        End If
    Next i

    Set GetTables = rv

End Function

[HansV]

Try this:

Code: Select all

Sub ImportWordTables()
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim wdFileName As Variant
    Dim tableNo As Long
    Dim tableStart As Long
    Dim tableTot As Long
    Dim resultRow As Long
    Dim fStart As Boolean

    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)

    On Error Resume Next
    Set wdApp = GetObject(Class:="Word.Application")
    If wdApp Is Nothing Then
        Set wdApp = CreateObject(Class:="Word.Application")
        fStart = True
    End If
    On Error GoTo ErrHandler

    Set wdDoc = wdApp.Documents.Open(Filename:=wdFileName) 'open Word file

    tableTot = wdDoc.Tables.Count
    If tableTot = 0 Then
        MsgBox "This document contains no tables", vbExclamation, "Import Word Table"
    ElseIf tableTot > 1 Then
        tableStart = InputBox("This Word document contains " & tableTot & " tables." & vbCrLf & _
        "Enter the table to start from", "Import Word Table", "1")
    End If

    resultRow = 4

    For tableNo = tableStart To tableTot
        wdDoc.Tables(tableNo).Range.Copy
        Cells(resultRow, 1).Select
        ActiveSheet.PasteSpecial Format:="HTML"
        resultRow = resultRow + wdDoc.Tables(tableNo).Rows.Count + 1
    Next tableNo

ExitHandler:
    On Error Resume Next
    wdDoc.Close SaveChanges:=False
    If fStart Then
       wdApp.Quit SaveChanges:=False
    End If
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation, "Import Word Table"
    Resume ExitHandler
End Sub

The macro now also allows for .docx and .docm files.

[vaxo]

Oh Yes, and if we could change the code so that each table was reflected in different sheets is this possible??

Thanks in advanced,

[HansV]

For example:

Code: Select all

Sub ImportWordTables()
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim wdFileName As Variant
    Dim tableNo As Long
    Dim tableStart As Long
    Dim tableTot As Long
    Dim resultRow As Long
    Dim fStart As Boolean
    Dim wSheet As Worksheet

    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)

    On Error Resume Next
    Set wdApp = GetObject(Class:="Word.Application")
    If wdApp Is Nothing Then
        Set wdApp = CreateObject(Class:="Word.Application")
        fStart = True
    End If
    On Error GoTo ErrHandler

    Set wdDoc = wdApp.Documents.Open(Filename:=wdFileName) 'open Word file

    tableTot = wdDoc.Tables.Count
    If tableTot = 0 Then
        MsgBox "This document contains no tables", vbExclamation, "Import Word Table"
    ElseIf tableTot > 1 Then
        tableStart = InputBox("This Word document contains " & tableTot & " tables." & vbCrLf & _
        "Enter the table to start from", "Import Word Table", "1")
    End If

    resultRow = 4

    For tableNo = tableStart To tableTot
        Set wSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        wdDoc.Tables(tableNo).Range.Copy
        wSheet.Cells(resultRow, 1).Select
        wSheet.PasteSpecial Format:="HTML"
    Next tableNo

ExitHandler:
    On Error Resume Next
    wdDoc.Close SaveChanges:=False
    If fStart Then
       wdApp.Quit SaveChanges:=False
    End If
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation, "Import Word Table"
    Resume ExitHandler
End Sub

[vaxo]

Thanks Great Solution....