使用Excel宏VBA将Word文档中的第一个表复制到Excel

您未看到的代码有很多问题，因为错误处理对您而言效果不佳。我已经在下面更正了它们。On Error Resume Next并不能很好地揭示问题，因为当发生错误时，代码将一直向前运行。在编写例程时，您想通过捕获其中的大多数来纠正这些问题。

在进行编辑之前，我做了一些您应该养成的习惯：

1. 添加了Option Explict（这将使您难以在代码中引入错误，因为它需要显式的语法。这是一门很好的纪律，我对此并不鼓励）
2. 已编译。（在编写代码时定期执行此操作。它将帮助您解决整个过程中的问题）
3. 声明变量i。当我使用Option Explicit进行编译时，这已标记出来（这不会在代码中造成问题，但是如果您不使用显式变量，则很容易引入错误）

然后我更改为使用特定的对象引用

1. 设置对Word库的引用（这使调试方式更容易，因为您将在编辑器中拥有intellisense，并且可以使用[F2]浏览Word库）
2. 更新了对Word.Application和Word.Document的通用对象引用

然后，我修复了错误。

首先，我将错误处理更改为使用On Error GoTo，然后解决了在处理代码时发生的每个错误。

1. wdApp.Activate导致错误
2. wdDoc从未真正创建过，所以没什么

更正这些错误之后，我添加了一行以获取名称中带有“ V1.2.doc”的文档。

最后，我删除了循环，因此仅将第一个表复制为所请求的问题。

Option Explicit

Public Sub ImportTableDataWord()
    Const FOLDER_PATH As String = "C:\Test\"

    Dim sFile As String

    'use the * wildcard to select the first file ending with "V1.2.doc" 
    sFile = Dir(FOLDER_PATH & "*V1.2.doc")

    If sFile = "" Then
        MsgBox "The file is not present or was not found"
        Exit Sub
    End If

    ImportTableDataWordDoc FOLDER_PATH & sFile

End Sub

Public Sub ImportTableDataWordDoc(ByVal strDocName As String)

    Dim WdApp As Word.Application
    Dim wddoc As Word.Document
    Dim nCount As Integer
    Dim rowWd As Long
    Dim colWd As Long
    Dim x As Long
    Dim y As Long
    Dim i As Long

    On Error GoTo EH

    If strDocName = "" Then
        MsgBox "The file is not present or was not found"
        GoTo FINISH
    End If

    Set WdApp = New Word.Application
    WdApp.Visible = False

    Set wddoc = WdApp.Documents.Open(strDocName)

    If wddoc Is Nothing Then
        MsgBox "No document object"
        GoTo FINISH
    End If

    x = 1
    y = 1

    With wddoc

        If .Tables.Count = 0 Then
            MsgBox "No Tables Found in the document"
            GoTo FINISH
        Else

            With .Tables(1)
                For rowWd = 1 To .Rows.Count
                    For colWd = 1 To .Columns.Count
                        Cells(x, y) = WorksheetFunction.Clean(.Cell(rowWd, colWd).Range.Text)
                        y = y + 1
                    Next 'colWd
                    y = 1
                    x = x + 1
                Next 'rowWd
            End With

        End If

    End With

    GoTo FINISH

EH:

    With Err
        MsgBox "Number" & vbTab & .Number & vbCrLf _
            & "Source" & vbTab & .Source & vbCrLf _
            & .Description
    End With

    'for debugging purposes
    Debug.Assert 0
    GoTo FINISH
    Resume

FINISH:

    On Error Resume Next
    'release resources

    If Not wddoc Is Nothing Then
        wddoc.Close savechanges:=False
        Set wddoc = Nothing
    End If

    If Not WdApp Is Nothing Then
        WdApp.Quit savechanges:=False
        Set WdApp = Nothing
    End If

End Sub