将表格从Word复制到Excel-VBA [英] Copying tables from Word to Excel-VBA

问题描述

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

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?

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

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

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

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

推荐答案

这适用于您的示例文档.可能在其他情况下 不起作用...

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

这篇关于将表格从Word复制到Excel-VBA的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！