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

Question

我正在 Excel (2010) 中编写一个宏，以从 Word (2010) 中复制 3 个书签的值并将它们粘贴到某个 Excel 范围内。

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

请注意我将使用它从多个具有相同书签的文档（大约 200 个）中获取名称、日期和整数。这将在不同的时间运行，具体取决于我何时评估文档的内容并将它们标记为已完成。

简要说明宏应该做什么：

1. 检查打开了多少 Word 文档，如果打开太多或没有打开，则返回 MsgBox。
2. 如果只打开了1个word文档，那么它应该引用word文档，选择相关的书签范围并复制数据。
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消息，

与

只要打开 1 个 word 文档，我就会收到以下内容：
“运行时错误'13'：类型不匹配”。

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

不幸的是，我没有找到任何其他涵盖此特定场景的问题/答案，也无法将一些代码放在一起弗兰肯斯坦。

编辑： Set xlWb = ThisWorkbook 已从修复运行时错误“13”的 Set xlWb = ActiveWorkbook 更改。

添加了有关运行时错误“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