邮件合并VBA导出PDF被覆盖，需按Excel中CPS命名独立文件

问题描述 #

执行邮件合并操作时，需将每条记录导出为独立PDF文件，以关联Excel中的CPS编号作为文件名。当前VBA代码能生成正确信件，但所有内容会被保存到同一个PDF文件并覆盖，需调整代码实现17000个命名正确的独立PDF。

修正后的VBA代码 #

Sub MergeBrieventool_ToPDFs()
    Dim mainDoc      As Document
    Dim singleDoc    As Document
    Dim dataPath     As String
    Dim outputFolder As String
    Dim totalRecs    As Long
    Dim i            As Long
    Dim CPS          As String

    ' 1) Excel数据源路径
    dataPath = "G:\Pensioenen\Contractbeheer\Contracten\2001-3000\2006\MVW2023\Brieventool.xlsx"
    
    ' 2) PDF输出文件夹（按日期创建子文件夹）
    outputFolder = "G:\Pensioenen\Contractbeheer\Contracten\2001-3000\2006\MVW2023\Brieven\" _
                   & Format(Date, "yyyymmdd") & "\"
    ' 检查文件夹是否存在，不存在则创建
    If Dir(outputFolder, vbDirectory) = "" Then MkDir outputFolder

    Set mainDoc = ActiveDocument

    ' 3) 连接Excel数据源
    With mainDoc.MailMerge
        .MainDocumentType = wdFormLetters
        .OpenDataSource Name:=dataPath, _
            ConfirmConversions:=False, ReadOnly:=True, LinkToSource:=True, _
            AddToRecentFiles:=False, Format:=wdOpenFormatAuto

        ' 4) 基础检查
        If .State <> wdMainAndDataSource Then
            MsgBox "无法连接数据源。", vbCritical
            Exit Sub
        End If
        totalRecs = .DataSource.RecordCount
        If totalRecs = 0 Then
            MsgBox "Excel中未找到记录。", vbExclamation
            Exit Sub
        End If

        ' 5) 设置合并目标为新文档
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True

        ' 关闭屏幕刷新提升处理速度（17000条记录必备）
        Application.ScreenUpdating = False

        ' 6) 遍历所有记录
        For i = 1 To totalRecs
            ' 6a) 定位到第i条记录
            .DataSource.FirstRecord = i
            .DataSource.LastRecord = i

            ' 6b) 获取CPS编号（需与Excel中列名完全匹配）
            On Error Resume Next
            CPS = Trim(.DataSource.DataFields("cps").Value)
            ' 若CPS为空，用序号命名避免覆盖
            If CPS = "" Then CPS = "Onb_" & i
            On Error GoTo 0

            ' 6c) 执行单条记录合并
            .Execute Pause:=False

            ' 6d) 准确获取合并生成的文档（替代ActiveDocument，避免激活异常）
            Set singleDoc = Documents(Documents.Count)

            ' 6e) 导出为PDF，文件名包含CPS编号
            singleDoc.ExportAsFixedFormat _
                OutputFileName:=outputFolder & "Brief_" & CPS & ".pdf", _
                ExportFormat:=wdExportFormatPDF, _
                OpenAfterExport:=False, _
                OptimizeFor:=wdExportOptimizeForPrint

            ' 6f) 关闭合并后的文档，不保存
            singleDoc.Close SaveChanges:=False
        Next i

        ' 恢复屏幕刷新
        Application.ScreenUpdating = True
    End With

    MsgBox "完成！已导出 " & totalRecs & " 份PDF至：" & vbCrLf & outputFolder, vbInformation
End Sub

关键修改说明 #

• 可靠获取合并文档：将Set singleDoc = ActiveDocument改为Set singleDoc = Documents(Documents.Count)，确保每次都能拿到最新生成的合并文档，避免因窗口激活问题导致的错误覆盖。
• 性能优化：添加Application.ScreenUpdating = False/True关闭屏幕刷新，大幅提升17000条记录的处理速度；增加OpenAfterExport:=False禁止导出后自动打开PDF，进一步减少资源消耗。
• 稳定性保障：保留原代码的错误捕获逻辑，确保CPS为空时生成唯一文件名，彻底避免文件覆盖。

注意事项 #

1. 确认Excel中的列名与代码中"cps"完全一致（大小写敏感）。
2. 确保输出文件夹所在磁盘有足够存储空间，17000份PDF需预留充足空间。
3. 执行前建议关闭Word的自动保存功能，避免中途卡顿。

内容的提问来源于stack exchange，提问作者Jeroen Van Der Putten