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

Question

我是Excel Macro和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库的引用 （这使调试方式更容易，因为您将在编辑器中拥有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