Sub RunMerge()
Dim wd As Object
Dim wdocSource As Object
Dim iMsgBox As Integer
Dim strDocumentName As String
Dim strSpreadsheetName As String
'Select Word mail merge template from user
strDocumentName = ThisWorkbook.Path & "\Target Sheets.docm"
strSpreadsheetName = ThisWorkbook.FullName
On Error Resume Next
Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then
Set wd = CreateObject("Word.Application")
End If
wd.Visible = False
' wd.DisplayAlerts = wdAlertsNone
On Error GoTo 0
Set wdocSource = wd.Documents.Open(strDocumentName)
'performs mailmerge
wdocSource.MailMerge.MainDocumentType = wdFormLetters
wdocSource.MailMerge.OpenDataSource Name:= _
strSpreadsheetName, ConfirmConversions:=False, _
ReadOnly:=False, LinkToSource:=True, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _
WritePasswordTemplate:="", Revert:=False, Format:=wdOpenFormatAuto, _
Connection:= _
"Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=strSpreadsheetName;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Engine Type=37;Jet OLEDB:Database Lockin" _
, SQLStatement:="SELECT * FROM `Class_Targets`", SQLStatement1:="", _
SubType:=wdMergeSubTypeAccess
With wdocSource.MailMerge
.Destination = wdSendToPrinter
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With
'Close the template without saving
wdocSource.Close savechanges:=False
'Unload the word resources
Set wdocSource = Nothing
Set wd = Nothing
End Sub
Thanks snb but it's working fine so I'll leave it the way it is.
Bookmarks