Word邮件合并生成带CPS编号的单个PDF问题求助

问题背景 #

需基于Word模板，通过邮件合并关联含姓名、地址、CPS编号的Excel数据源，批量生成17500份以对应CPS编号命名的PDF文件，但现有VBA代码无法正确提取CPS值作为文件名。

原代码核心问题 #

1. 字段提取不可靠：通过打开合并文档后更新字段再遍历提取CPS值，存在字段更新延迟，容易获取空值或错误内容
2. 效率极低：循环打开17500个独立文档，会大幅拖慢处理速度，甚至导致Word程序崩溃

修正后的VBA代码 #

Sub MergeToPDF_CorrectCPS()
    Dim outputFolder As String
    Dim i As Long
    Dim doc As Document
    Dim pdfFileName As String
    Dim CPS As String
    Dim dataSource As MailMergeDataSource
    
    ' 关闭屏幕更新，提升处理速度
    Application.ScreenUpdating = False
    
    Set doc = ActiveDocument
    Set dataSource = doc.MailMerge.dataSource
    
    ' 构建输出文件夹路径，确保末尾有分隔符
    outputFolder = "G:\2001-3000\2006\MVW2023\Brieven" & Format(Date, "yyyymmdd") & "\"
    If Dir(outputFolder, vbDirectory) = "" Then MkDir outputFolder

    With doc.MailMerge
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True

        For i = 1 To dataSource.RecordCount
            ' 定位到当前数据源记录
            dataSource.ActiveRecord = i
            ' 直接从数据源读取CPS值，无需打开文档后提取
            On Error Resume Next
            CPS = Trim(dataSource.DataFields("CPS").Value)
            On Error GoTo 0
            
            ' 处理CPS为空的情况
            If CPS = "" Then CPS = "Onbekend_" & i

            ' 生成合法文件名
            pdfFileName = outputFolder & "Brief_" & CleanFileName(CPS) & ".pdf"

            ' 合并当前记录并导出为PDF
            .dataSource.FirstRecord = i
            .dataSource.LastRecord = i
            .Execute Pause:=False
            
            ' 导出刚生成的文档为PDF
            Documents(Documents.Count).ExportAsFixedFormat _
                OutputFileName:=pdfFileName, _
                ExportFormat:=wdExportFormatPDF
            ' 关闭临时文档，不保存
            Documents(Documents.Count).Close SaveChanges:=wdDoNotSaveChanges
        Next i
    End With

    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    MsgBox "PDF已保存至: " & outputFolder
End Sub

Function CleanFileName(text As String) As String
    Dim invalidChars As Variant
    Dim i As Integer
    invalidChars = Array("/", "\", ":", "*", "?", """", "<", ">", "|")
    For i = LBound(invalidChars) To UBound(invalidChars)
        text = Replace(text, invalidChars(i), "_")
    Next i
    CleanFileName = Trim(text)
End Function

关键改动说明 #

1. 直接读取数据源：通过dataSource.DataFields("CPS").Value直接从Excel数据源获取CPS值，避免了字段更新延迟问题，同时提升效率
2. 优化处理流程：先定位数据源记录获取CPS，再执行合并导出，逻辑更清晰
3. 性能优化：添加Application.ScreenUpdating = False关闭屏幕刷新，大幅提升批量处理速度
4. 错误处理：增加On Error Resume Next处理CPS字段不存在的情况，避免程序中断
5. 路径规范：确保输出文件夹路径末尾包含分隔符，避免文件名拼接错误

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