Copying tables from Word to Excel-VBA

问题

I am trying to copy multiple tables from a Microsoft Word Doc to Excel. The code is unable to find any tables in the word document which I think is due to the fact that the tables are located near the center of the page of each document and not near the top. Does anyone know how I can modify the code so I can successfully copy the tables?

I have tried using for loops instead of tableNo = wdDoc.Tables.Count but have had no success.

The code I have tried is from a previous thread which has been successful when the tables are located near the top of each page of the word document.

https://stackoverflow.com/a/9406983/7282657

回答1:

This worked for me with your sample document. Likely there may be other scenarios where it might not work...

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

来源：https://stackoverflow.com/questions/41111444/copying-tables-from-word-to-excel-vba