Excel 中的邮件合并 - 不稳定的宏行为

Question

下午好，

我已经设置了一个宏来根据这个线程 (Automating Mail Merge using Excel VBA) 生成单独的证书。但是宏总是表现不规律，一天工作，第二天又向我抛出错误。

我得到的最常见错误是 Excel 正在等待另一个应用程序 (Word) 执行 OLE 操作。但有时会出现运行时错误，它不想知道对象。

我已经重新设计了宏，希望一劳永逸地对问题进行排序，但在我关闭 Word 之前，当前的错误不喜欢“结束于”。我有 3 个“Withs”，为什么不喜欢 3 个“End Withs”。 - 我不只是想取出“结束于”，因为我认为一个人不会为每个证书打开 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

Answer 1

如果你缩进你的代码并去掉“不重要”的东西，你最终会得到这样的结果：

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

如果你看一下，你很快就会发现 With/End With 块和 For/Next 循环不匹配。

因为在For 循环中只有两个With 语句，但有三个End With 语句，编译器会“感到困惑”并坚持要求您更正错误。