VBA Excel - Mail Merge to PDF Looping through datasets - excel

Question

Here is the scenario. I am using VBA in Excel 2016 to initiate a mail merge with Word. The data source for the merge is a spreadsheet in the current Excel document. The routine generates a separate merge document for each iteration of a dataset.
As I loop through the datasets, a new merge doc is created and saved as a PDF document.
Issue #1:
The routine as it loops creates the separate merge docs. Each merge doc is visible, so if I loop through 5 datasets, I get 5 open merge docs, each with the appropriate dataset values. But when saving as PDF, it saves the first merge doc over and over again.
In my code, the "Save As PDF" section generates a unique filename based on a field from the dataset and that works. Each saved PDF has the appropriate filename, but the actual file is the first merge doc over and over again.
How can I get the routine to save the first merge doc as PDF and then move on to the next iteration?
Issue #2:
As the routine loops and creates the independent merge docs, how can I then close the newly created word merge docs?
Existing code:
z = 0
For z = 0 To xCount - 1
lb2_selected = "''" + lb2_array(0, z) + "''"
addr_query = "sp_address_filter '" + lb2_selected + "','" + lb1_selected + "','','" + lb3_selected + "','',''"
'MsgBox (addr_query)
Set rs = conn.Execute(addr_query)
'Clear any existing data from Sheet2
Worksheets("Sheet2").Range("A1:Z10000").Clear
'Load new iteration of data into Sheet2
With rs
For h = 1 To .Fields.Count
Sheet2.Cells(1, h) = .Fields(h - 1).Name
Sheet2.Cells(1, h).Font.Bold = True
Next h
End With
If Not rs.EOF Then
Sheets(2).Range("A2").CopyFromRecordset rs
End If
rs.Close
'Set value for filename
lb2_array_value = lb2_array(1, z)
Dim wd As Object
Dim wdocSource As Object
Dim strWorkbookName As String
Set wd = CreateObject("Word.Application")
Set wdocSource = wd.Documents.Open("c:\users\john\documents\LabelPage3.docx")
strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name
wdocSource.MailMerge.MainDocumentType = wdFormLetters
wdocSource.MailMerge.OpenDataSource _
Name:=strWorkbookName, _
AddToRecentFiles:=False, _
Revert:=False, _
Format:=wdOpenFormatAuto, _
Connection:="Data Source=" & strWorkbookName & ";Mode=Read", _
SQLStatement:="SELECT * FROM `Sheet2$`"
With wdocSource.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With
ActiveDocument.ExportAsFixedFormat OutputFileName:= _
"C:\users\john\documents\labels\" + lb2_array_value + ".pdf", _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
wd.Visible = True
wdocSource.Close SaveChanges:=False
Set wdocSource = Nothing
Set wd = Nothing
Next z

Answer 1

Several issues emerge with your current setup. Consider the following adjustments:
MS WORD OBJECT: ActiveDocument is part of the MS Word object library and not Excel. By not qualifying it with a Word.Application object, you are assuming it for Excel. Therefore, qualify it accordingly: wd.ActiveDocument. On my end, doing this hangs Excel infinitely without error.
EARLY BINDING Since none of your Word constants are declared, you seem to have a VBA reference to MS Word Object Library checked off. Therefore, do not mix late-binded with early binding calls:
Change the following:
Dim wd As Object
Dim wdocSource As Object
...
Set wd = CreateObject("Word.Application")
To the below:
Dim wd As Word.Application
Dim wdocSource As Word.Document
...
Set wd = New Word.Application
LOOP PROCESS: Place your Word object assignment outside of the loop as only the documents need to be set and unset inside the loop. And use the Application.Quit method to effectively close out the object.
Dim wd As Word.Application
Dim wdocSource As Word.Document
...
Set wd = New Word.Application
wd.Visible = True
For z = 0 To xCount - 1
... ' SHEET QUERY PROCESS
Set wdocSource = wd.Documents.Open("c:\users\john\documents\LabelPage3.docx")
... ' MAIL MERGE PROCESS
wdocSource.Close SaveChanges:=False
Set wdocSource = Nothing
Next z
wd.Quit False
Set wd = Nothing
WITH BLOCK: For easy readability, consistently use the With...End With block for MailMerge process:
With wdocSource.MailMerge
.MainDocumentType = wdFormLetters
.OpenDataSource _
Name:=strWorkbookName, _
AddToRecentFiles:=False, _
Revert:=False, _
Format:=wdOpenFormatAuto, _
Connection:="Data Source=" & strWorkbookName & ";Mode=Read", _
SQLStatement:="SELECT * FROM `Sheet2$`"
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With
ERROR HANDLING: As best practice, wrap entire process in error handling especially to destroy objects as code resulting in runtime error will leave object running as a background process.
Public Sub RunMailMerge()
On Error GoTo ErrHandle
...
ExitHandle:
wdocSource.Close SaveChanges:=False
Set wdocSource = Nothing
wd.Quit False
Set wd = Nothing
Exit Sub
ErrHandle:
MsgBox Err.Number & " - " & Err.Description, vbCritical, "RUNTIME ERROR"
Resume ExitHandle
End Sub