使用excel宏VBA将第一个表从word文档复制到excel

Question

我是 Excel 宏和 VBA 的新手。

我需要使用宏 VBA 将表格数据从 Word 文档复制到 Excel 工作表。

我需要在特定文件夹中的多个文档版本中执行文档 V1.2 版本。 例如：我有文件 "C:\Test\FirstDocV1.1.doc" 和 "C:\Test\FirstDocV1.2.doc"。

我只想执行"C:\Test\FirstDocV1.2.doc" 并获取表数据。 无论如何我都试过了，但它说的是“没有桌子”。

查看我的代码如下。

Sub importTableDataWord()
    Dim WdApp As Object, wddoc As Object
    Dim strDocName As String

    On Error Resume Next
    Set WdApp = GetObject(, "Word Application")

    If Err.Number = 429 Then
       Err.Clear
        Set WdApp = CreateObject("Word Application")
    End If

    WdApp.Visible = True
    strDocName = "C:\Test\FirstDocV1.2.doc"

'I am manually giving for version 1.2 doc. But I need to select which contains v1.2 version automatically from Test folder.    
    If Dir(strDocName) = "" Then
        MsgBox "The file is not present" & strDocName & vbCrLf & " or was not found"
        Exit Sub
    End If

    WdApp.Activate
    Set wddoc = WdApp.Documents(strDocName)

    If wddoc Is Nothing Then Set wddoc = WdApp.Documents.Open(strDocName)
        wddoc.Activate
        Dim Tble As Integer
        Dim rowWd As Long
        Dim colWd As Long
        Dim x As Long, y As Long

        x = 1
        y = 1

        With wddoc
            Tble = wddoc.tables.Count
            If Tble = 0 Then
                MsgBox "No Tables Found in the document"
                Exit Sub
            End If

            For i = 1 To Tble
                With .tables(i)
                    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
            Next
        End With

    wddoc.Close savechanges:=False
    WdApp.Quit

    Set wddoc = Nothing
    Set WdApp = Nothing
End Sub

谁能帮帮我。

Answer 1

您没有看到的代码存在许多问题，因为错误处理对您来说效果不佳。我在下面更正了它们。 On Error Resume Next 不是很清楚，因为当发生错误时，代码只是继续向前运行。你想通过在编写例程时捕捉其中的大部分来纠正这些问题。

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

1. 添加了 Option Explict（这将使在代码中引入错误变得更加困难，因为它需要明确的语法。这是一门很棒的学科，我不能鼓励它）
2. 编译。 （在编写代码时定期执行此操作。它将帮助您解决问题）
3. 声明了变量 i。这在我使用 Option Explicit 编译时被标记（不会在您的代码中创建问题，但如果您不使用显式变量，则很容易引入错误）

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

1. 设置对 Word 库的引用（这使调试变得更容易，因为您将在编辑器中拥有智能感知功能，并且可以使用 [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