如何拆分邮件合并并以合并字段作为名称保存文件

我设置了一堆邮件合并模板，当我合并文档时，我想将结果拆分为单独的文件，每个文件的名称基于合并字段“FileNumber”。

我目前拥有的代码是：

Sub splitter()
' Based on a macro by Doug Robbins to save each letter created by a mailmerge as a separate file.
' With help from http://www.productivitytalk.com/forums/topic/3927-visual-basic-question-for-merge-fields/

Dim i As Integer
Dim Source As Document
Dim Target As Document
Dim Letter As Range
Dim oField As Field
Dim FileNum As String

Set Source = ActiveDocument

For i = 1 To Source.Sections.Count
    Set Letter = Source.Sections(i).Range
    Letter.End = Letter.End - 1
        For Each oField In Letter.Fields
        If oField.Type = wdFieldMergeField Then
            If InStr(oField.Code.Text, "FileNumber") > 0 Then
            'get the result and store it the FileNum variable
            FileNum = oField.Result
            End If
        End If
        Next oField
    Set Target = Documents.Add
    Target.Range = Letter
    Target.SaveAs FileName:="C:\Temp\Letter" & FileNum
    Target.Close
    Next i
End Sub

问题是，如果我“合并到新文档”，那么“FileNumber”字段不再存在，因此它无法拾取该字段，但如果我只是转到“预览结果”并运行宏，它只会保存当前预览的记录，并且不是其余的字母。

我假设我需要将代码更改为类似的内容

For i = 1 To Source.MergedRecord.Count
    Set Letter = Source.MergedRecord(i).Range

但我无法找出正确的语法。

我知道http://www.gmayor.com/individual_merge_letters.htm http://www.gmayor.com/individual_merge_letters.htm但我不需要对话框，我只想要一个一键按钮。

在邮件合并模板文档中，将以下宏代码粘贴到“ThisDocument“ 模块：

Dim WithEvents wdapp As Application
Dim bCustomProcessing As Boolean

Private Sub Document_Open()

Set wdapp = Application
bCustomProcessing = False
ThisDocument.MailMerge.DataSource.ActiveRecord = 1
ThisDocument.MailMerge.ShowWizard 1
With ActiveDocument.MailMerge
   If .MainDocumentType = wdFormLetters Then
       .ShowSendToCustom = "Custom Letter Processing"
   End If
End With

End Sub
Private Sub wdapp_MailMergeWizardSendToCustom(ByVal Doc As Document)

bCustomProcessing = True
Doc.MailMerge.Destination = wdSendToNewDocument
With Doc.MailMerge
    For rec = 1 To .DataSource.RecordCount
        .DataSource.ActiveRecord = rec
        .DataSource.FirstRecord = rec
        .DataSource.LastRecord = rec
        .Execute
    Next
End With

MsgBox "Merge Finished"
End Sub


Private Sub wdapp_MailMergeAfterMerge(ByVal Doc As Document, ByVal DocResult As Document)
If bCustomProcessing = True Then
    With Doc.MailMerge.DataSource.DataFields
        sFirmFileName = .Item(1).Value ' First Column of the data - CHANGE
    End With
    DocResult.SaveAs "c:\path\" & sFirmFileName & ".docx", wdFormatXMLDocument
     ' Path and File Name to save. can use other formats like wdFormatPDF too
    DocResult.Close False
End If
End Sub

请记住更新用于文件名的列号以及保存生成的文件的路径。

编写此代码后，保存并关闭合并模板文档。重新打开该文件，这次系统将提示您合并向导。按照信件的要求进行操作，并在最后一步选择“Custom Letter Processing" 选项而不是完成合并。这会将单独的合并文档保存在指定的文件夹中。

请记住，此代码可能会对处理器造成沉重负担。