Using Excel VBA to Copy MS Word bookmark range and Paste into Excel

Question

I am writing a macro in Excel (2010) to copy the value of 3 bookmarks from Word (2010) and paste them into a certain Excel Range.

I've found several similar questions here and on other various forums however most are macros in Word and don't have the correct references for what I need.

Please note I will be using this to grab a Name, Date and Integer from multiple documents (approx. 200) which all have the same bookmarks. This will be run at different times depending on when I assess the contents of the document and mark them as completed.

To give a quick rundown of what the macro should do:

Check how many Word documents are open and return a MsgBox if too many or none are open.
If Only 1 word document is open, it should then reference the word document, select the relevant bookmark Range and copy the data.
It should then return to Excel and paste the data in the specified range and cell reference.

Here is my current code (and below this is my list of issues):

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

So as indicated in the code, the second ElseIf statement returns Runtime Error '462' "The remote server machine does not exist or is unavailable" rather than the vbInformation message,

AND

As long as there is 1 word document open I receive the following:
"Run-time error '13': Type mismatch".

Also a Run-time error '438' is present on the wdDoc.Copy line

Unfortunatley I haven't found any other questions/answers that cover this specific scenario nor have I been able to Frankenstein some code together.

EDIT: Set xlWb = ThisWorkbook was changed from Set xlWb = ActiveWorkbook which fixed Run-time error '13'.

Added info regarding Run-time error '438'.

Subodh Tiwari sktneer Subodh Tiwari sktneer · Accepted Answer · 2018-04-27T06:30:55

Please try it like this...

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

Using Excel VBA to Copy MS Word bookmark range and Paste into Excel

1 Answers