Good Afternoon,
I have set up a macro to generate individual certificates based on this thread (Automating Mail Merge using Excel VBA). But the macro has always behaved erratically, working one day, throwing errors at me the next.
The most frequent error I get is that Excel is waiting for another application (Word) to perform an OLE action. But at times there are runtime errors where it doesn't want to know the objects.
I have reworked the macro, hoping to sort the issues once and for all but the current error doesn't like the "End With" before I close the Word. I have 3 "Withs", so why doesn't it like 3 "End Withs". - I don't just want to take out the "End With" because I it makes sense to me that one doesn't open Word for each certificate and close it again. That is asking for problems.
The macro is set to go through the Excel sheet, evaluate column K (r, 11) and if it's empty (meaning the certificate hasn't been generated yet), perform the mailmerge and save the document as a pdf into the defined folder.
This is the code. Can anybody see why VBA has a problem with it? 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 cDir As String
Dim r As Long
Dim ThisFileName As String
FirstName = sh1.Cells(r, 1).Value
LastName = sh1.Cells(r, 2).Value
Training = sh1.Cells(r, 3).Value
SeminarDate = Format(sh1.Cells(r, 4).Value, "d mmmm YYYY")
HoursComp = sh1.Cells(r, 5).Value
Location = sh1.Cells(r, 6).Value
Objectives = sh1.Cells(r, 7).Value
Trainer = sh1.Cells(r, 8).Value
'Your Sheet names need to be correct in here
Set sh1 = ActiveWorkbook.Sheets("Ultrasound")
'Setup filenames
Const WTempName = "Certificate_Ultrasound_2017.docx" 'Template name
'Data Source Location
cDir = ActiveWorkbook.Path + "\" 'Change if required
ThisFileName = ThisWorkbook.Name
On Error Resume Next
'Create Word instance
bCreatedWordInstance = False
Set objWord = CreateObject("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 `Ultrasound$`" ' Set this as required
lastrow = Sheets("Ultrasound").Range("A" & Rows.Count).End(xlUp).Row
r = 2
For r = 2 To lastrow
If IsEmpty(Cells(r, 11).Value) = False Then GoTo nextrow
With objMMMD.MailMerge 'With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = r - 1
.LastRecord = r - 1
.ActiveRecord = r - 1
End With
.Execute Pause:=False
End With
'Save new file PDF
Dim UltrasoundCertPath As String
UltrasoundCertPath = "C:\Users\305015724\Documents\ApplicationsTraining\2016\Ultrasound\"
Dim YYMM As String
YYMM = Format(sh1.Cells(r, 16).Value, "YYMM")
Dim NewFileNamePDF As String
NewFileNamePDF = YYMM & "_" & sh1.Cells(r, 3).Value & "_" & sh1.Cells(r, 7).Value '& ".pdf" 'Change File Name as req'd"
objWord.ActiveDocument.ExportAsFixedFormat UltrasoundCertPath & NewFileNamePDF, ExportFormat:=wdExportFormatPDF
End With
' Close the Mail Merge Main Document
objMMMD.Close savechanges:=wdDoNotSaveChanges
Set objMMMD = Nothing
If bCreatedWordInstance Then
objWord.Quit
End If
Set objWord = Nothing
Cells(r, 11).Value = Date
0:
Set objWord = Nothing
nextrow:
Next r
End Sub
