将表格从 Word 复制到 Excel-VBA答案

【问题标题】：Copying tables from Word to Excel-VBA将表格从 Word 复制到 Excel-VBA
【发布时间】：2018-07-31 23:52:44
【问题描述】：

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

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

我尝试的代码来自上一个线程，当表格位于 word 文档每一页的顶部附近时，该线程已成功。

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

【问题讨论】：

您确定它们实际上是您文档中的表格吗？如果您单击其中一个，它会激活“表格工具”选项卡吗？
是的，100% 确定有桌子。如果我将表格拖到更靠近 word 页面顶部的位置，则代码可以正常工作。谢谢你的提问。
听起来很奇怪，但如果没有可使用的示例“问题”文档，我们可能无法提供太多服务。
很奇怪，我在@TimWilliams 问题中提供了示例链接
您的表格包含在一个 Shape 对象中：它没有直接插入到文档中

标签： vba excel ms-word

【解决方案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

【讨论】：