Option Explicit

Sub CopyWorksheet()
'Graham Mayor - https://www.gmayor.com - Last updated - 26 Feb 2020
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Dim bStarted As Boolean, bOpen As Boolean
Dim strWB As String
Const strSheet As String = "Sheet1"    'the name of the sheet to copy
Const strBM As String = "BookmarkName"    ' the name of the bookmark
    
    strWB = BrowseForFile("Select Workbook", True)

    If strWB = "" Then
        Beep
        GoTo lbl_Exit
    End If
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err Then
        Set xlApp = CreateObject("Excel.Application")
        bStarted = True
    End If
    On Error GoTo lbl_Exit
    xlApp.Visible = True

    For Each xlBook In xlApp.Workbooks
        If xlBook.Name = strWB Then
            bOpen = True
            Exit For
        End If
    Next xlBook
    If Not bOpen Then Set xlBook = xlApp.Workbooks.Open(FileName:=strWB)

    Set xlSheet = xlBook.Sheets(strSheet)
    xlSheet.UsedRange.Copy
    If ActiveDocument.Bookmarks.Exists(strBM) = False Then
        MsgBox "Bookmark " & strBM & " does not exist?"
    Else
        XLSheetToBM strBM
    End If
    xlApp.DisplayAlerts = False
    xlApp.DisplayAlerts = True
    If bStarted = True Then
        xlBook.Close 0
        xlApp.Quit
    End If
lbl_Exit:
    Set xlApp = Nothing
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Exit Sub
End Sub

Private Sub XLSheetToBM(strbmName As String)
'Graham Mayor - https://www.gmayor.com
Dim oRng As Range
    With ActiveDocument
        On Error GoTo lbl_Exit
        Set oRng = .Bookmarks(strbmName).Range
        oRng.Text = ""
        oRng.PasteSpecial _
                link:=False, _
                DataType:=wdPasteBitmap, _
                Placement:=wdInLine, _
                DisplayAsIcon:=False
        oRng.Start = oRng.Start - 1
        oRng.Bookmarks.Add strbmName
    End With
lbl_Exit:
    Set oRng = Nothing
    Exit Sub
End Sub

Private Function BrowseForFile(Optional strTitle As String, Optional bExcel As Boolean) As String
'Graham Mayor - https://www.gmayor.com
'strTitle is the title of the dialog box
'Set bExcel value to True to filter the dialog to show Excel files
'The default is to show Word files
Dim fDialog As FileDialog
    On Error GoTo err_Handler
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    With fDialog
        .TITLE = strTitle
        .AllowMultiSelect = False
        .Filters.Clear
        If bExcel Then
            .Filters.Add "Excel workbooks", "*.xls,*.xlsx,*.xlsm"
        Else
            .Filters.Add "Word documents", "*.doc,*.docx,*.docm"
        End If
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then GoTo err_Handler:
        BrowseForFile = fDialog.SelectedItems.Item(1)
    End With
lbl_Exit:
    Exit Function
err_Handler:
    BrowseForFile = vbNullString
    Resume lbl_Exit
End Function

Sub CopyWorksheet()
'Graham Mayor - https://www.gmayor.com - Last updated - 04 Mar 2020
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Dim bStarted As Boolean, bOpen As Boolean
Dim strWB As String
Dim strBM As String
Dim strSheet As String

    strWB = BrowseForFile("Select Workbook", True)

    If strWB = "" Then
        Beep
        GoTo lbl_Exit
    End If
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err Then
        Set xlApp = CreateObject("Excel.Application")
        bStarted = True
    End If
    On Error GoTo lbl_Exit
    xlApp.Visible = True

    For Each xlBook In xlApp.Workbooks
        If xlBook.Name = strWB Then
            bOpen = True
            Exit For
        End If
    Next xlBook
    If Not bOpen Then Set xlBook = xlApp.Workbooks.Open(FileName:=strWB)

'Repeat this section to define each bookmark and the sheet/range you wish to copy to it
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    strBM = "BookmarkName1"    ' the name of the bookmark
    strSheet = "Sheet1"      'the name of the sheet to copy
    
    Set xlSheet = xlBook.Sheets(strSheet)
    xlSheet.UsedRange.Copy
    If ActiveDocument.Bookmarks.Exists(strBM) = False Then
        MsgBox "Bookmark " & strBM & " does not exist?"
    Else
        XLSheetToBM strBM
    End If
 '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    
    xlApp.DisplayAlerts = False
    xlApp.DisplayAlerts = True
    If bStarted = True Then
        xlBook.Close 0
        xlApp.Quit
    End If
lbl_Exit:
    Set xlApp = Nothing
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Exit Sub
End Sub