使用Excel VBA复制MS Word书签范围并粘贴到Excel中

Question

我正在Excel（2010）中编写宏，以从Word（2010）复制3个书签的值并将其粘贴到某个Excel Range中。

我在这里和其他各种论坛上都发现了几个类似的问题，但是大多数都是Word中的宏，并且没有我需要的正确参考。

请注意，我将使用它从多个具有相同书签的多个文档（大约200个）中获取名称，日期和整数。 根据我评估文档内容并将其标记为完成的时间，此操作将在不同的时间运行。

快速概述宏应该做什么：

1. 检查打开了多少个Word文档，如果打开太多或没有打开，则返回一个MsgBox。
2. 如果仅打开了一个Word文档，则应引用该Word文档，选择相关的书签Range并复制数据。
3. 然后应返回Excel并将数据粘贴到指定的范围和单元格引用中。

这是我当前的代码（下面是我的问题列表）：

Private Sub cmdImport_Click()
Dim intDocCount As Integer
Dim wdApp As Word.Application, wdDoc As Word.Document, xlWb As Excel.Workbook, xlWs As Excel.Worksheet

Set wdApp = Word.Application
Set wdDoc = ActiveDocument
Set xlWb = ThisWorkbook 'Edited from ActiveWorkbook
Set xlWs = ActiveWorkbook.Sheets("Sheet1")
intDocCount = Word.Application.Documents.Count

        If intDocCount = 1 Then
            GoTo Import
        ElseIf intDocCount > 1 Then
            MsgBox "There are " & intDocCount & " Word Documents open." & vbNewLine & vbNewLine & _
            "Please close the additional MS Word Documents", vbCritical, "Too many Word Documents open!"
                Exit Sub
        ElseIf intDocCount < 1 Then 'Currently shows Runtime Error 462 rather than MsgBox
            MsgBox "There are no MS Word Documents open.", vbInformation, "No Word Documents open"
                Exit Sub
        End If

Import:
        With wdApp
            wdDoc.Activate
            wdDoc.Bookmarks("test").Range.Select
            wdDoc.Copy 'Run-time error '438' here
        End With
        With xlWb
            xlWs.Activate
            xlWs.Cells(2, 1) = Selection 
            xlWs.Paste
        End With
End Sub

因此，如代码中所示，第二条ElseIf语句返回运行时错误'462'“远程服务器计算机不存在或不可用”，而不是vbInformation消息，

和

只要打开一个Word文档，我就会收到以下信息：
“运行时错误'13'：类型不匹配”。

在wdDoc.Copy行上还存在运行时错误'438'

不幸的是，我还没有找到其他涉及此特定场景的问题/答案，也没有我能够一起进行科学怪人的代码编写。

编辑： Set xlWb = ThisWorkbook已从Set xlWb = ActiveWorkbook更改，后者修复了运行时错误'13'。

添加了有关运行时错误“ 438”的信息。

Answer 1

请这样尝试...

Private Sub cmdImport_Click()
Dim intDocCount As Integer
Dim wdApp As Word.Application, wdDoc As Word.Document, xlWb As Excel.Workbook, xlWs As Excel.Worksheet
Dim BookmarkText As String

On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
On Error GoTo 0

If wdApp Is Nothing Then
    MsgBox "There are no MS Word Documents open.", vbInformation, "No Word Documents open"
    Exit Sub
End If

Set xlWb = ThisWorkbook 'Edited from ActiveWorkbook
Set xlWs = ActiveWorkbook.Sheets("Sheet1")
intDocCount = wdApp.Documents.Count

If intDocCount > 1 Then
    MsgBox "There are " & intDocCount & " Word Documents open." & vbNewLine & vbNewLine & _
    "Please close the additional MS Word Documents", vbCritical, "Too many Word Documents open!"
    Set wdApp = Nothing
    Exit Sub
End If


With wdApp
    Set wdDoc = wdApp.ActiveDocument
    wdDoc.Activate
    BookmarkText = wdDoc.Bookmarks("test").Range.Text
End With

xlWs.Cells(2, 1) = BookmarkText

End Sub