Runtime error 5631 - excel

I am trying to generate certificates using the records from my Excel master data file. My coding throws me a VBA error "Runtime error - 5631; Word could not merge the main document with the data source because the data records were empty or no data records matched your query options" every alternate time.
For some data, the code works, whereas for most of the time, it throws error 5631 in the line .Execute Pause:=False
There are records inside the file, so I know there is something wrong with my Query itself.
Other info:
Temp1 = Cookies mailmerge word template,
Temp2 = Chocolates mailmerge word template,
Temp3 = Drinks mailmerge word template
Sheet1 = Cookies sales excel data,
Sheet2 = Chocolates sales excel data,
Sheet3 = Drinks sales excel data
My complete code:
Sub Generate_Cert()
Dim wd As Object
Dim wdoc As Object
Dim i As Integer
Dim isInvalid As Boolean
Dim statement, fileSuffix, datasource As String
Dim aSheet As Worksheet
Dim cDir As String
Dim wdName As String
Const wdFormLetters = 0
Const wdOpenFormatAuto = 0
Const wdSendToNewDocument = 0
Const wdDefaultFirstRecord = 1
Const wdDefaultLastRecord = -16
SalesDate = Format(Worksheets("SalesMaster").Cells(2, "B").Value, "DDMMYYYY")
On Error Resume Next
'Check Word is open or not
Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then
'If Not open, open Word Application
Set wd = CreateObject("Word.Application")
End If
On Error GoTo 0
'Getting datasource
datasource = ThisWorkbook.Path & "\" & ThisWorkbook.Name
'Looping all sheet from workbook
For Each aSheet In ThisWorkbook.Sheets
'If the first cell is not empty
If aSheet.Range("A2").Value <> "" Then
isInvalid = False
'Check sheet for SQLStatement and save file name.
Select Case aSheet.Name
Case "Sheet1"
statement = "SELECT * FROM `Sheet1$`"
fileSuffix = " Cookies Sales"
i = 1
Case "Sheet2"
statement = "SELECT * FROM `Sheet2$`"
fileSuffix = " Chocolates Sales"
i = 2
Case "Sheet3"
statement = "SELECT * FROM `Sheet3$`"
fileSuffix = " Drinks Sales"
i = 3
Case Else
isInvalid = True
End Select
'If sheet should save as word
If Not isInvalid Then
'Getting new word document
Set wdoc = wd.Documents.Open("C:\Desktop\Sales Certs\Temp" & i & ".docx")
With wdoc.MailMerge
.MainDocumentType = wdFormLetters
.OpenDataSource Name:=datasource, AddToRecentFiles:=False, _
Revert:=False, Format:=wdOpenFormatAuto, _
Connection:="Data Source=" & datasource & ";Mode=Read", _
SQLStatement:=statement
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .datasource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With
'wdoc.Visible = True
wdName = SalesDate & fileSuffix & ".docx"
cDir = ActiveWorkbook.Path + "\"
wd.ActiveDocument.SaveAs cDir + wdName
MsgBox SalesDate & fileSuffix & " has been generated and saved"
'wdoc.SaveAs Filename:=wdoc.Name
wdoc.Close SaveChanges:=True
End If
End If
Next aSheet
wd.Quit SaveChanges:=wdDoNotSaveChanges
End Sub

This error was occurring because my source excel document was not saved before the Mailmerge execution. No need to save the word document, as there was no pre-processing necessary before the Mailmerge execution.
So I basically declared wBook as workbook & added this : wBook.Save
Sub Generate_Cert()
Dim wd As Object
Dim wdoc As Object
Dim i As Integer
Dim isInvalid As Boolean
Dim statement, fileSuffix, datasource As String
Dim wBook As Workbook
Dim aSheet As Worksheet
Dim cDir As String
Dim wdName As String
Const wdFormLetters = 0
Const wdOpenFormatAuto = 0
Const wdSendToNewDocument = 0
Const wdDefaultFirstRecord = 1
Const wdDefaultLastRecord = -16
wBook.save '<~~~~~~~ SAVE BEFORE MAILMERGE STARTS
SalesDate = Format(Worksheets("SalesMaster").Cells(2, "B").Value, "DDMMYYYY")
On Error Resume Next
'Check Word is open or not
Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then
'If Not open, open Word Application
Set wd = CreateObject("Word.Application")
End If
On Error GoTo 0
'Getting datasource
datasource = ThisWorkbook.Path & "\" & ThisWorkbook.Name
'Looping all sheet from workbook
For Each aSheet In ThisWorkbook.Sheets
'If the first cell is not empty
If aSheet.Range("A2").Value <> "" Then
isInvalid = False
'Check sheet for SQLStatement and save file name.
Select Case aSheet.Name
Case "Sheet1"
statement = "SELECT * FROM `Sheet1$`"
fileSuffix = " Cookies Sales"
i = 1
Case "Sheet2"
statement = "SELECT * FROM `Sheet2$`"
fileSuffix = " Chocolates Sales"
i = 2
Case "Sheet3"
statement = "SELECT * FROM `Sheet3$`"
fileSuffix = " Drinks Sales"
i = 3
Case Else
isInvalid = True
End Select
'If sheet should save as word
If Not isInvalid Then
'Getting new word document
Set wdoc = wd.Documents.Open("C:\Desktop\Sales Certs\Temp" & i & ".docx")
With wdoc.MailMerge
.MainDocumentType = wdFormLetters
.OpenDataSource Name:=datasource, AddToRecentFiles:=False, _
Revert:=False, Format:=wdOpenFormatAuto, _
Connection:="Data Source=" & datasource & ";Mode=Read", _
SQLStatement:=statement
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .datasource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With
'wdoc.Visible = True
wdName = SalesDate & fileSuffix & ".docx"
cDir = ActiveWorkbook.Path + "\"
wd.ActiveDocument.SaveAs cDir + wdName
MsgBox SalesDate & fileSuffix & " has been generated and saved"
'wdoc.SaveAs Filename:=wdoc.Name
wdoc.Close SaveChanges:=True
End If
End If
Next aSheet
wd.Quit SaveChanges:=wdDoNotSaveChanges
End Sub

Related

MailMerge: From Excel to Word Saving Individual Documents for Each Record While Maintaining Link to Source

First I want to say I am extremely new to utilizing VBA to make my excel sheets more efficient.
I started a few months back and mainly generate code by piecing together what I find online then edit to meet my specific needs.
What Current Code Does:
What I have created allows me to perform a multiple document mailmerge from excel to merge records from my datasoure (Project Information) with the click of a button. Before performing the merge, the user identifies 5 conditions;
Zoning (ex. R20; located in cell C8)
Easement Type (ex. TE; located in cell F8)
The Template to use from the previously uploaded template list (located in cell J8)
The Area of the Lot (located in cell P8)
If it is a just compensation Report ("yes" or "no" located in cell C11)
The criteria above identifies the record numbers that match the specified criteria to create individual mailmerge documents for each record and saves in the corresponding property file which is associated with the record number. The sheet that is generating mailmerge ("report Creation") is different from the datasource and maintains records of when the mailmerge was performed and what template was used. This sheet also contains the list of records and is the search range for the criteria (record start on line 39 so +37 is used to match "Report Creation" row).The code also contains a loading bar that appears when the merging is being performed and shows percentage complete (percentage is not correct but used more to show user merge is in progress).
My Question:
What I am now trying to adjust is when the mailmerge is performed I still want the individual documents but I want to maintain the link between the new document and the datasource. That way I can always update the word document if any changes occur. It currently merges to a word document that no longer contains any mailmerge field and is as if I finalized a merge.
I am assuming this is a minor change after the .opendatasource but cant pinpoint what to change.
My Code may be a bit messy and could definitely use some cleanup but it gets the job done. See below.
Current Code:
Sub RunMerge()
Dim StrMMSrc As String, StrMMDoc As String, StrMMDocName As String, StrName As String, dataname As String
Dim i As Long
Dim Load As Integer
Dim wdApp As New Word.Application
Dim wdDoc As Word.Document
Dim ReportNum, AddressName, SaveLoc, NewFile, fpath, subfldr, DateCr As String
Dim ExpTemp, ExTempDate, ExpReview, ExpRevDate As Range
Dim ExpRow, CustCol, lastRow, StrMMDocRow, ExportedDoc, LotSizeSM, LotSizeLG, ActualLS, symbpos As Long
Dim FileName, Zoning, Ease, LotSizeRNG, Ztype, Etype As String
On Error GoTo errhandler
'Turn off at the start
TurnOffFunctionality
wdApp.DisplayAlerts = wdAlertsNone
Set wsreports = ThisWorkbook.Worksheets("Report Creation")
Set wsinfo = ThisWorkbook.Worksheets("Project Information")
Set wsdetails = ThisWorkbook.Worksheets("Project Details")
StrMMSrc = ThisWorkbook.fullname
lastRow = wsinfo.Columns("A").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlValues).row
dataname = wsinfo.Name
'set folder path for saving documents
fpath = ThisWorkbook.Sheets("Project Details").Range("E30").Value
subfldr = wsdetails.Range("F34").Value
'date exported
DateCr = Format(Date, "mm-dd-yyyy")
ExportedDoc = 0
With wsreports
' set range criteria
LotSizeRNG = .Range("P8").Value
symbpos = InStr(1, LotSizeRNG, "<>")
LotSizeSM = CInt(Left(LotSizeRNG, symbpos - 1))
LotSizeLG = CInt(Mid(LotSizeRNG, symbpos + 2))
If LotSizeLG = "" Then LotSizeLG = 100000000
If wsreports.Range("J8").Value = Empty Then
MsgBox "Please Select A Template From The Dropdown List to Export"
wsreports.Range("J8").Select
GoTo errhandler
End If
StrMMDocRow = .Application.Match(Range("J8").Value, .Range("C1:C34"), 0) 'Set Template Row
StrMMDocName = .Range("J8").Value 'set template name
Zoning = .Range("C8").Value 'set Zoning Criteria
Ease = .Range("F8").Value 'Set Easement Criteria
StrMMDoc = .Range("AB" & StrMMDocRow).Value 'Word Document Filename
End With
wdApp.Visible = False
Set wdDoc = wdApp.Documents.Open(FileName:=StrMMDoc, AddToRecentFiles:=False)
With wdDoc
With .MailMerge
.MainDocumentType = wdFormLetters
.OpenDataSource Name:=StrMMSrc, AddToRecentFiles:=False, LinkToSource:=False,
ConfirmConversions:=False, _
ReadOnly:=True, Format:=wdOpenFormatAuto, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"User ID=Admin;Data Source=" & StrMMSrc & ";Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";", _
SQLStatement:="SELECT * FROM `Project Information$`", SQLStatement1:="", SubType:=wdMergeSubTypeAccess
UserFormLoad.Show
For i = 2 To lastRow
Ztype = wsreports.Range("D" & i + 37).Value
Etype = wsreports.Range("F" & i + 37).Value
ActualLS = wsreports.Range("E" & i + 37).Value
'Check the row for matching zone and easement cristeria
If wsreports.Range("C11").Value = "No" And StrMMDocName <> wsreports.Range("H" & i + 37).Value _
And Ztype = Zoning And ActualLS >= LotSizeSM And ActualLS <= LotSizeLG And Etype = Ease Then
ExportedDoc = ExportedDoc + 1
'set newfile location
ReportNum = wsreports.Range("B" & i + 37).Value
AddressName = wsreports.Range("C" & i + 37).Value
SaveLoc = fpath & "\#" & ReportNum & "_" & AddressName & "\" & subfldr
'generate new file name with date
NewFile = SaveLoc & "\" & AddressName & "_Draft Report_" & DateCr & ".docx"
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i - 1
.LastRecord = i - 1
.ActiveRecord = i - 1
StrName = NewFile
End With
.Execute Pause:=False
wsreports.Range("I" & i + 37).Value = StrMMDocName
wsreports.Range("L" & i + 37).Value = DateCr
With wdApp.ActiveDocument
.SaveAs FileName:=StrName, FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
' and/or:
'.SaveAs Filename:=StrMMPath & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close savechanges:=False
End With
Dim r As Integer
r = i
Load = Application.WorksheetFunction.RoundDown((r + 1) / (lastRow) * 100, 0)
DoEvents
UserFormLoad.LoadBar.Width = Load / 100 * 222
UserFormLoad.LabelProg.Caption = Load & "%"
End If
Next i
Unload UserFormLoad
.MainDocumentType = wdNotAMergeDocument
End With
.Close savechanges:=False
End With
If ExportedDoc = 0 Then
MsgBox "No Properties Matched The Criteria Specified. Use The Table To Verify The Easement and Zoning Have Properties Meeting Criteria.", vbOKOnly, "No Matches Found"
Else
MsgBox "The Property Draft Reports Were Exported Successfully. Please Check Project Property" & subfldr & " Folder for Word Document.", vbOKOnly, "Export Successfull"
End If
'cleanup if error
errhandler:
TurnOnFunctionality
wdApp.DisplayAlerts = wdAlertsAll
Set wdDoc = Nothing
Set wdApp = Nothing
End Sub
You cannot use mailmerge for what you want to achieve. You would need to use LINK fields instead of MERGEFIELDs and update the LINK field row references for each output document.
An alternative approach would be to re-run the mailmerge for just the record(s) you want to update.

Save Excel mailmerge to PDF only on the last row with data

I have been using a code which uses mailmerge from the excel sheet to my word template and then proceeds to save all the rows in my excel sheet to PDF(in the word template of course). - The code works perfectly fine.
The code was taken from this forum :
https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
How my Excel sheet looks like :
A1-E1 = Headers
A2-E2 = data
A3-E3 = data
A4-E4 = data
and so on...
How the code currently works :
The code saves all rows of data from the excel sheet into my word template(with mailmerge) and then into PDFs.
My goal :
I want to change the code so it only saves the last row of data in the excel sheet into my word template(with mailmerge) and then into to PDF.
Sub RunMerge()
' Sourced from: https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
' Note: this code requires a reference to the Word object model to be set, via Tools|References in the VBE.
Application.ScreenUpdating = False
Dim StrMMSrc As String, StrMMDoc As String, StrMMPath As String, StrName As String
Dim i As Long, j As Long
Const StrNoChr As String = """*./\:?|"
Dim wdApp As New Word.Application, wdDoc As Word.Document
wdApp.Visible = False
wdApp.DisplayAlerts = wdAlertsNone
StrMMSrc = ThisWorkbook.FullName
StrMMPath = ThisWorkbook.Path & "\"
StrMMDoc = StrMMPath & "MailMergeDocument.doc"
Set wdDoc = wdApp.Documents.Open(Filename:=StrMMDoc, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With wdDoc
With .MailMerge
.MainDocumentType = wdFormLetters
.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 `Sheet1$`"
For i = 1 To .DataSource.RecordCount
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("Name")) = "" Then Exit For
StrName = .DataFields("Name")
End With
.Execute Pause:=False
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
Next
StrName = Trim(StrName)
With wdApp.ActiveDocument
'Add the name to the footer
'.Sections(1).Footers(wdHeaderFooterPrimary).Range.InsertBefore StrName
'.SaveAs Filename:=StrMMPath & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
' and/or:
.SaveAs Filename:=StrMMPath & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
Next i
.MainDocumentType = wdNotAMergeDocument
End With
.Close SaveChanges:=False
End With
wdApp.DisplayAlerts = wdAlertsAll
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing
Application.ScreenUpdating = False
End Sub
Thanks in advance.
Replace:
For i = 1 To .DataSource.RecordCount
with:
i = .DataSource.RecordCount
or, if there are rows in use below that in other columns:
i = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row - 1
where 'A' is any column not containing data below the last record and delete both:
If Trim(.DataFields("Name")) = "" Then Exit For
and:
Next i

Excel VBA mail merge with conditions

I am really looking forward to get some help because I am trying for so long now...
I want to get a button in excel that starts a word mailmerge and save every letter as a single document. I already found a code, that is doing this fine.
Now comes the problem: I need excel to take different word templates depending on the number in column A (Column A is called Anz). So if column A = 0 there wont be any mail merge (I already managed this by adding "where (Anz>0) to the sql statement.
If column A = 1 excel shall take sb1.docx as the proper mail merge template.
If column A = 2 it shall take sb2.docx and so on.
The numbers go from 0 to 6.
I have no idea how to to this :(
My code so far (that is working but only for the sb1.docx).
Sub RunMerge()
Application.ScreenUpdating = False
Dim StrMMSrc As String, StrMMDoc As String, StrMMPath As String, StrName As String
Dim i As Long, j As Long
Const StrNoChr As String = """*/\:?|"
Dim wdApp As New Word.Application, wdDoc As Word.Document
wdApp.Visible = False
wdApp.DisplayAlerts = wdAlertsNone
StrMMSrc = ThisWorkbook.FullName
StrMMPath = ThisWorkbook.Path & "\"
StrMMDoc = StrMMPath & "sb1.docx"
Set wdDoc = wdApp.Documents.Open(Filename:=StrMMDoc, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With wdDoc
With .MailMerge
.MainDocumentType = wdFormLetters
.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 `Sheet1$` where (Anz>0)"
For i = 1 To .DataSource.RecordCount
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("ID")) = "" Then Exit For
StrName = .DataFields("ID")
End With
.Execute Pause:=False
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
Next
StrName = Trim(StrName)
With wdApp.ActiveDocument
.SaveAs Filename:=StrMMPath & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
' and/or:
'.SaveAs Filename:=StrMMPath & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
Next i
.MainDocumentType = wdNotAMergeDocument
End With
.Close SaveChanges:=False
End With
wdApp.DisplayAlerts = wdAlertsAll
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing
Application.ScreenUpdating = False
End Sub
Try this.
Requirements:
- Each Anz number has it's corresponding template
- The excel spreadsheet has a column called "Anz"
- You have to add the Microsoft Word object library to VBA IDE references
Implementation:
1) Copy and paste the code inside a vba module
2) Customize the code (seek for >>>> customize this <<<<)
Updates:
1) Adjusted the queryString
2) Updated the OpenDataSource code to be more clear
3) Added a fileCounter
Code:
' First you have to configure the settings in each template so the word template filters the data already
' Also add a reference in Excel / VBA IDE to: Microsoft Word [Version] Object Library
Public Sub RunMergeDifferentWordTemplates()
' Declare objects
Dim wordApp As Word.Application
Dim wordTemplate As Word.Document
Dim wordMergedDoc As Word.MailMerge
' Declare other variables
Dim sourceBookPath As String
Dim sheetSourceName As String
Dim excelColumnFilter As String
Dim queryString As String
Dim baseQueryString As String
Dim wordTemplateDirectory As String
Dim wordTemplateFileName As String
Dim wordTemplateFullPath As String
Dim wordOutputDirectory As String
Dim wordOutputFileName As String
Dim wordOutputFullPath As String
Dim idListValues As Variant ' Array
Dim idValue As Integer
Dim idCounter As Integer
Dim recordCounter As Integer
Dim fileCounter As Integer
' >>>>> Customize this <<<<<<
' This would be better to hold it in an Excel structured table
' I'm not including 0 as it's not needed (these would correspon to the anz values).
idListValues = Array(1, 2, 3, 4, 5, 6)
' Excel source settings:
sourceBookPath = ThisWorkbook.FullName
sheetSourceName = "Sheet1" ' The sheet where the data of the mail merge is located
excelColumnFilter = "Anz" ' The column we use to filter the mail merge data
baseQueryString = "SELECT * FROM `" & sheetSourceName & "$` where `" & excelColumnFilter & "` = [columFilterValue] order by `" & excelColumnFilter & "` ASC" ' Would be a better practice to use an Excel structured table: https://support.office.com/en-us/article/overview-of-excel-tables-7ab0bb7d-3a9e-4b56-a3c9-6c94334e492c
' Word settings:
wordTemplateDirectory = ThisWorkbook.Path & "\" ' Include slash at the end
wordTemplateFileName = "sb[columFilterValue].docx" ' Include in the string [columFilterValue] where you want it to be replaced (remember that you have one template for each number)
wordOutputDirectory = ThisWorkbook.Path & "\" ' Include slash at the end
wordOutputFileName = "MailMergeDifferent[columFilterValue]_[Record]" ' Leave the [columFilterValue] and [Record] tags inside the path to identify each document. We'll replace it ahead, dynamically
' Initialize word object
Set wordApp = New Word.Application
wordApp.Visible = True
wordApp.DisplayAlerts = wdAlertsNone
' Loop through each idValue in idListValues
For idCounter = 0 To UBound(idListValues)
' Process each word template
idValue = idListValues(idCounter)
queryString = Replace(baseQueryString, "[columFilterValue]", idValue)
wordTemplateFullPath = wordTemplateDirectory & Replace(wordTemplateFileName, "[columFilterValue]", idValue)
Set wordTemplate = wordApp.Documents.Open(wordTemplateFullPath)
Set wordMergedDoc = wordTemplate.MailMerge
' Process the template's mail merge
With wordMergedDoc
.MainDocumentType = wdFormLetters
.OpenDataSource _
Name:=sourceBookPath, _
ReadOnly:=True, _
Format:=wdOpenFormatAuto, _
Revert:=False, _
AddToRecentFiles:=False, _
LinkToSource:=False, _
Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
"Data Source=" & sourceBookPath & ";Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
SQLStatement:=queryString
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
' Each anz have matching records inside the excel worksheet (generate a word file for each one)
For recordCounter = 1 To .DataSource.RecordCount
' Select each record
With .DataSource
.FirstRecord = wordMergedDoc.DataSource.ActiveRecord
.LastRecord = wordMergedDoc.DataSource.ActiveRecord
End With
.Execute Pause:=False
' Add the columnFilterValue and the record identifier to the word file name
' Replace the columnFilterValue and the Record tags
wordOutputFullPath = wordOutputDirectory & Replace(Replace(wordOutputFileName, "[columFilterValue]", idValue), "[Record]", recordCounter)
' Save and close the resulting document
wordApp.ActiveDocument.SaveAs2 Filename:=wordOutputFullPath, FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
wordApp.ActiveDocument.SaveAs2 Filename:=wordOutputFullPath, FileFormat:=wdFormatPDF, AddToRecentFiles:=False
wordApp.ActiveDocument.Close SaveChanges:=False
.DataSource.ActiveRecord = wdNextRecord
' Count files generated
fileCounter = fileCounter + 1
Next recordCounter
End With
' Close word template without saving
wordTemplate.Close False
Next idCounter
' Clean up word objects
wordApp.Visible = False
Set wordApp = Nothing
' Alert process finished
MsgBox fileCounter & " files generated"
End Sub

VBA Mailmerge to pdf Output

Good Morning
I have modified the code from this post: Automating Mail Merge using Excel VBA
But I only want pdf output but as soon as I take out the word code, it baulks. I think the problem is that if I don't save it as word, it doesn't shut the template down properly (there is code to close it). I have to manually click "Don't Save" and then it chokes as it tries to reopen the file for the next line. Any idea how to get around that? - Any help much appreciated. Thanks.
Public Sub MailMergeCert()
Dim bCreatedWordInstance As Boolean
Dim objWord As Word.Application
Dim objMMMD As Word.Document
Dim FirstName As String
Dim LastName As String
Dim Training As String
Dim SeminarDate As String
Dim HoursComp As String
Dim Location As String
Dim Objectives As String
Dim Trainer As String
Dim r As Long
Dim ThisFileName As String
'Your Sheet names need to be correct in here
Set sh1 = Sheets("Periop")
lastrow = Sheets("Periop").Range("A" & Rows.Count).End(xlUp).Row
r = 2
For r = 2 To lastrow
If IsEmpty(Cells(r, 10).Value) = False Then GoTo nextrow
FirstName = sh1.Cells(r, 1).Value
LastName = sh1.Cells(r, 2).Value
Training = sh1.Cells(r, 3).Value
SeminarDate = sh1.Cells(r, 4).Value
HoursComp = sh1.Cells(r, 5).Value
Location = sh1.Cells(r, 6).Value
Objectives = sh1.Cells(r, 7).Value
Trainer = sh1.Cells(r, 8).Value
SeminarDate = Format(sh1.Cells(r, 4).Value, "d mmmm YYYY")
' Setup filenames
Const WTempName = "Certificate_Periop_2016.docx" 'Template name
' Setup directories
cDir = ActiveWorkbook.Path + "\" 'Change if required
ThisFileName = ThisWorkbook.Name
On Error Resume Next
' Create a Word Application instance
bCreatedWordInstance = False
Set objWord = GetObject(, "Word.Application")
If objWord Is Nothing Then
Err.Clear
Set objWord = CreateObject("Word.Application")
bCreatedWordInstance = True
End If
If objWord Is Nothing Then
MsgBox "Could not start Word"
Err.Clear
On Error GoTo 0
Exit Sub
End If
' Let Word trap the errors
On Error GoTo 0
' Set to True if you want to see the Word Doc flash past during construction
objWord.Visible = False
'Open Word Template
Set objMMMD = objWord.Documents.Open(cDir + WTempName)
objMMMD.Activate
'Merge the data
With objMMMD
.MailMerge.OpenDataSource Name:=cDir + ThisFileName, sqlstatement:="SELECT * FROM `Periop$`" ' Set this as required
With objMMMD.MailMerge 'With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = r - 1
.LastRecord = r - 1
.ActiveRecord = r - 1
' EmployeeName = .EmployeeName
End With
.Execute Pause:=False
End With
End With
' Save new file
'Path and YYMM
Dim PeriopCertPath As String
PeriopCertPath = "C:\Users\305015724\Documents\ApplicationsTraining\2016\Periop\"
Dim YYMM As String
YYMM = Format(sh1.Cells(r, 11).Value, "YYMM")
'Word document
Dim NewFileNameWd As String
NewFileNameWd = YYMM & "_" & sh1.Cells(r, 12).Value & "_" & sh1.Cells(r, 2).Value & ".docx" 'Change File Name as req'd"
objWord.ActiveDocument.SaveAs Filename:=PeriopCertPath & NewFileNameWd
'PDF
Dim NewFileNamePDF As String
NewFileNamePDF = YYMM & "_" & sh1.Cells(r, 12).Value & "_" & sh1.Cells(r, 2).Value '& ".pdf" 'Change File Name as req'd"
objWord.ActiveDocument.ExportAsFixedFormat PeriopCertPath & NewFileNamePDF, ExportFormat:=wdExportFormatPDF
' Close the Mail Merge Main Document
objMMMD.Close savechanges:=wdDoNotSaveChanges
Set objMMMD = Nothing
' Close the New Mail Merged Document
If bCreatedWordInstance Then
objWord.Quit
End If
0:
Set objWord = Nothing
Cells(r, 10).Value = Date
nextrow:
Next r
End Sub
I recorded saving a workbook as a pdf and this is the output:
ActiveDocument.ExportAsFixedFormat OutputFileName:= _
"C:\Users\me\Desktop\Doc1.pdf", ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=True, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
wdExportAllDocument, From:=1, To:=1, Item:=wdExportDocumentContent, _
IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:= _
wdExportCreateNoBookmarks, DocStructureTags:=True, BitmapMissingFonts:= _
True, UseISO19005_1:=False
It seems like you might try:
objWord.ActiveDocument.ExportAsFixedFormat PeriopCertPath & NewFileNamePDF,
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False
The pdf generation always worked and I think I now have the Word bit sorted as well. This is the part of the code that generates the pdf and then closes Word (and a few other things ...)
'Print Certificate
'Print required
If sh1.Cells(r, 12) = "print" Then
'remove background image
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.WholeStory
Selection.Cut
'Print Certificate
objWord.ActiveDocument.PrintOut
'Close the Mail Merge Main Document
objWord.ActiveDocument.Close (wdDoNotSaveChanges)
objMMMD.Close savechanges:=wdDoNotSaveChanges
Set objMMMD = Nothing
Else
'Close the Mail Merge Main Document
objWord.ActiveDocument.Close (wdDoNotSaveChanges)
objMMMD.Close savechanges:=wdDoNotSaveChanges
Set objMMMD = Nothing
End If
' Create a Word Application instance
bCreatedWordInstance = False
Set objWord = GetObject(, "Word.Application")
' Close the New Mail Merged Document
If bCreatedWordInstance Then
objWord.Quit
End If
0:
Set objWord = Nothing

Executing Word Mail Merge

I have an excel sheet with data and want to export it to a new word document.
Is it possible to start MAIL MERGE from excel macro by clicking a button on the sheet?
If your Word document is already configured with the merge fields, and you are running the macro from the workbook that contains the data you want to merge into the Word document, then try this:
Sub RunMerge()
Dim wd As Object
Dim wdocSource As Object
Dim strWorkbookName As String
On Error Resume Next
Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then
Set wd = CreateObject("Word.Application")
End If
On Error GoTo 0
Set wdocSource = wd.Documents.Open("c:\test\WordMerge.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 `Sheet1$`"
With wdocSource.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With
wd.Visible = True
wdocSource.Close SaveChanges:=False
Set wdocSource = Nothing
Set wd = Nothing
End Sub
To get dendarii's solution to work I had to declare Word constants in Excel VBA as follows:
' Word constants
Const wdFormLetters = 0, wdOpenFormatAuto = 0
Const wdSendToNewDocument = 0, wdDefaultFirstRecord = 1, wdDefaultLastRecord = -16
If your word document is already configured with data source and merge fields layout then it becomes much simpler. In the example below MailMergeLayout.doc is all setup ready to perform a merge. A button in Excel is linked to RunMailMerge() as below. All the code is contained in an Excel VBA module.
Sub RunMailMerge()
Dim wdOutputName, wdInputName As String
wdOutputName = ThisWorkbook.Path & "\Reminder Letters " & Format(Date, "d mmm yyyy")
wdInputName = ThisWorkbook.Path & "\MailMergeLayout.doc"
' open the mail merge layout file
Dim wdDoc As Object
Set wdDoc = GetObject(wdInputName, "Word.document")
wdDoc.Application.Visible = True
With wdDoc.MailMerge
.MainDocumentType = wdFormLetters
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
.Execute Pause:=False
End With
' show and save output file
wdDoc.Application.Visible = True
wdDoc.Application.ActiveDocument.SaveAs wdOutputName
' cleanup
wdDoc.Close SaveChanges:=False
Set wdDoc = Nothing
End Sub
Private Sub CommandButton1_Click()
Set wordapp = CreateObject("word.Application")
wordapp.documents.Open "C:\Documents and Settings\User\Desktop\mergeletter.doc"
wordapp.Visible = True
wrddoc = wordapp.documents("C:\Users\User\Desktop\sourceofletters.xls")
wrddoc.mailmerge.maindocumenttype = wdformletters
With wrddoc.activedocument.mailmerge
.OpenDataSource Name:="C:\Users\User\Desktop\sourceofletters.xls", _
SQLStatement:="SELECT * FROM `Sheet1`"
End With
End Sub
Above code is to open a word mailmerge document (with its source link and mergefield codes all setup ) all I want is for the message box "Opening the document will run the following SQL command " to be made available to the user , from that point forward the user could either select 'Yes' or 'No'.
Dim opt As String
opt = MessageBox("Opening the document will run the following SQL command", vbYesNo)
If opt = vbYes Then
'execute query
End If

Resources