MailMerge из Excel — ошибочное поведение макроса

Добрый день,

Я настроил макрос для создания отдельных сертификатов на основе этого потока (Автоматизация слияния с помощью Excel VBA). Но макрос всегда вел себя хаотично, работал один день, а на следующий выдавал мне ошибки.

Наиболее частая ошибка, которую я получаю, заключается в том, что Excel ожидает другого приложения (Word) для выполнения действия OLE. Но иногда возникают ошибки времени выполнения, когда он не хочет знать объекты.

Я переработал макрос, надеясь решить проблемы раз и навсегда, но текущая ошибка не любит «Конец с», прежде чем я закрою Word. У меня 3 "С", так почему бы не 3 "Конца с". - Я не просто хочу убрать «Конец с», потому что мне кажется, что нельзя открывать Word для каждого сертификата и снова закрывать его. Это напрашивается на проблемы.

Макрос настроен на просмотр листа Excel, оценку столбца K (r, 11) и, если он пуст (это означает, что сертификат еще не создан), выполнить слияние и сохранить документ в формате pdf в указанную папку.

Это код. Кто-нибудь может понять, почему у VBA с этим проблемы? Спасибо!

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