从Excel MailMerge-不稳定的宏行为

Question

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

Answer 1

If you indent your code and get rid of the "unimportant" stuff, you end up with this:

Public Sub MailMergeCert()
    '...
    With objMMMD
        '...
        For r = 2 To lastrow
            '...
            With objMMMD.MailMerge
                '...
                With .DataSource
                    '...
                End With
                '...
            End With
            '...
        End With
        '...
    Next r

End Sub

If you look at that, you soon see that you have a mismatch of With / End With blocks and For / Next loops.

Because you only have two With statements within the For loop, but you have three End With statements, the compiler gets "confused" and insists that you correct the error.