Question

我正在尝试将多个表从Microsoft Word文档复制到Excel。代码无法在word文档中找到任何表格，我认为这是因为表格位于每个文档的页面中心附近而不是靠近顶部。有谁知道我如何修改代码，以便我可以成功复制表？

我尝试使用for循环代替tableNo = wdDoc.Tables.Count，但没有成功。

我尝试过的代码来自之前的一个帖子，当桌子位于word文档每页顶部附近时，该代码已经成功。

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

Answer 1

这对我的样本文档起作用了。可能还有其他情况可能不工作......

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

将表从Word复制到Excel-VBA

1 个答案: