Использование Excel VBA для копирования диапазона закладок MS Word и вставки в Excel

Question

Я пишу макрос в Excel (2010), чтобы скопировать значение 3 закладок из Word (2010) и вставить их в определенный диапазон Excel.

Я нашел несколько похожих вопросов здесь и на других форумах, однако большинство из них - макросы в Word, и в них нет правильных ссылок на то, что мне нужно.

Обратите внимание Я буду использовать это для получения Имени, Даты и Целого числа из нескольких документов (около 200), которые имеют одинаковые закладки. Это будет выполняться в разное время, в зависимости от того, когда я оцениваю содержимое документа и отмечаю его как завершенное.

Чтобы дать краткое изложение того, что макрос должен сделать:

1. Проверьте, сколько документов Word открыто, и выведите MsgBox, если открыто слишком много документов или их нет.
2. Если открыт документ только из одного слова, он должен ссылаться на документ слова, выбрать соответствующий диапазон закладок и скопировать данные.
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 слова, я получаю следующее:
«Ошибка времени выполнения« 13 »: несоответствие типов».

Кроме того, ошибка времени выполнения '438' присутствует в строке wdDoc.Copy

К сожалению, я не нашел никаких других вопросов / ответов, которые касаются этого конкретного сценария, и я не смог собрать вместе Франкенштейна некоторый код.

РЕДАКТИРОВАТЬ: 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