Sub RunMerge()
    Dim strWorkbookName As String
    strWorkbookName = ThisWorkbook.FullName
    Dim wdapp As Word.Application
    Set wdapp = New Word.Application
    Dim wddoc As Word.Document
    With wdapp
        'Disable alerts to prevent an SQL prompt
        .DisplayAlerts = wdAlertsNone
        'Open the mailmerge main document
        Set wddoc = .Documents.Open(ThisWorkbook.Path & "\Mail Merge Main Document.docx", _
    ConfirmConversions:=False, ReadOnly:=True, AddToRecentfiles:=False)
        With wddoc
            With .MailMerge
                'Define the mailmerge type
                .MainDocumentType = wdFormLetters
                'Connect to the data source
                .OpenDataSource Name:=strWorkbookName, ReadOnly:=True, _
                  AddToRecentFiles:=False, LinkToSource:=False, _
                  Connection:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
                  "User ID=Admin;Data Source=strWorkbookName;" & _
                  "Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
                  SQLStatement:="SELECT * FROM `Sheet1$`", _
                  SubType:=wdMergeSubTypeAccess
                .SuppressBlankLines = True
                With .DataSource
                    .FirstRecord = wdDefaultFirstRecord
                    .LastRecord = wdDefaultLastRecord
                End With
                'Define the output
                .Destination = wdSendToNewDocument
                'Excecute the merge
                .Execute
                'Disconnect from the data source
                .MainDocumentType = wdNotAMergeDocument
            End With
            'Close the mailmerge main document
            .Close False
        End With
        'Restore the Word alerts
        .DisplayAlerts = wdAlertsAll
        'Print the output document
        .ActiveDocument.PrintOut
        'Display Word and the document
        .Visible = True
    End With
End Sub