Sub RunMerge()
' Sourced from: http://www.vbaexpress.com/forum/showthread.php?70461-Change-Word-mailmerge-source-with-VBA
' Note: this code requires a reference to the Word object model to be set, via Tools|References in the VBE.
On Error GoTo Err_Handler
Application.ScreenUpdating = False
Dim StrMMSrc As String, StrMMDoc As String, StrMMPath As String, StrName As String, strPDFName As String
Dim iLastRow As Integer
StrMMSrc = ThisWorkbook.FullName
StrMMPath = ThisWorkbook.Path & "\"
StrMMDoc = "F:\Users\Paul\Documents\Test Address Details 7165 MM.docx"
StrName = ActiveSheet.Name 'InputBox("Please input the name of the source worksheet")
If Trim(StrName) = "" Then Exit Sub
'Trim Filter column else we get extra records with no values
iLastRow = GetLastRow(StrName, "A") + 1
ActiveSheet.Range("A" & iLastRow & ":J1000").ClearContents
Dim wdApp As New Word.Application, wdDoc As Word.Document
wdApp.Visible = True
wdApp.WordBasic.DisableAutoMacros
wdApp.DisplayAlerts = wdAlertsNone
'StrMMDoc = StrMMPath & "MailMergeMainDocument.doc"
Set wdDoc = wdApp.Documents.Open(Filename:=StrMMDoc, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With wdDoc
With .MailMerge
.MainDocumentType = wdMailingLabels
.OpenDataSource Name:=StrMMSrc, ReadOnly:=True, AddToRecentFiles:=False, _
LinkToSource:=False, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
"Data Source=StrMMSrc;Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
SQLStatement:="SELECT * FROM `" & StrName & "$`"
.Execute Pause:=False
.MainDocumentType = wdNotAMergeDocument
End With
' .Close SaveChanges:=False
'Save as PDF file
strPDFName = "GCCS Passengers - " & StrName
With wdApp.ActiveDocument
.SaveAs Filename:=StrMMPath & strPDFName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
'.Close SaveChanges:=False
End With
'wdApp.Documents("Labels1").ExportAsFixedFormat OutputFileName:= _
' StrMMPath & strPDFName & ".pdf", _
' ExportFormat:=wdExportFormatPDF, _
' OpenAfterExport:=True, _
' OptimizeFor:=wdExportOptimizeForPrint, _
' Range:=wdExportAllDocument, _
' IncludeDocProps:=True, _
' CreateBookmarks:=wdExportCreateWordBookmarks, _
' BitmapMissingFonts:=True
End With
wdApp.DisplayAlerts = wdAlertsAll
'MsgBox "Mailmerge document created. Switching to Word application, document Labels1"
wdApp.Activate
Err_Resume:
Set wdDoc = Nothing
Set wdApp = Nothing
Application.ScreenUpdating = True
Exit Sub
Err_Handler:
MsgBox "Error " & Err.Number & " - " & Err.Description
Resume Err_Resume
End Sub