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

How to split a mail merge and save files with a merge field as the name

提问by Hybrid

I have a bunch of mail merge templates setup, when I merge the documents I want to split the results into separate files each one with a name based on the merge field “FileNumber”.

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

The code I have currently is:

我目前拥有的代码是：

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

The problem is if I “Merge to new document” then the “FileNumber” field no longer exists so it can't pick that up but if I just go to “Preview Results” and run the macro it only saves the currently previewed record and not the rest of the letters.

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

I'm assuming I need to change the code to something like

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

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

but I can't work out the correct syntax.

但我无法计算出正确的语法。

I am aware of http://www.gmayor.com/individual_merge_letters.htmbut I don't want the dialog boxes I just want a one click button.

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

回答by swarajk1

In the Mail merge template document, paste the following macro code in "ThisDocument" module:

在邮件合并模板文档中，将以下宏代码粘贴到“ 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

Remember to update the column number to use for file names, and the path to save the generated files.

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

After writing this code, save and close the merge template doc. Re-open the file and this time you will be prompted with the Merge wizard. Proceed as required for the Letter, and at the last step, select "Custom Letter Processing" option instead of finishing merge. This will save the separate merged docs in specified folder.

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

Please remember that this code can be heavy on the processor.

请记住，此代码对处理器来说可能很重。

回答by S?ren Francis

There is a simple solution not involving splitting the resulting document: Prepare the merge and staying in the template document.Record a macro as you merge one record, then save and close the resulting file, eventuallye advance to the next record.

有一个不涉及拆分结果文档的简单解决方案：准备合并并保留在模板文档中。在合并一条记录时录制一个宏，然后保存并关闭结果文件，最终前进到下一条记录。

See the generated macro below. I have added very little code just to extract the filename from a field in the datasource (which is accessible in the template document).

请参阅下面生成的宏。我添加了很少的代码只是为了从数据源中的字段中提取文件名（可在模板文档中访问）。

Assign the macro to a shortcut key or implement a loop in VBA. Observe that the fieldnames are casesensitive.

将宏分配给快捷键或在 VBA 中实现循环。请注意字段名区分大小写。

Regards, S?ren

问候， S?ren

Sub flet1()
'
' flet1 Makro
' 1) Merges active record and saves the resulting document named by the datafield     FileName"
' 2) Closes the resulting document, and (assuming that we return to the template)
' 3) advances to the next record in the datasource
'
'S?ren Francis 6/7-2013

    Dim DokName  As String   'ADDED CODE

    With ActiveDocument.MailMerge
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
        With .DataSource
            .FirstRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
            .LastRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
' Remember the wanted documentname
           DokName = .DataFields("FileName").Value         ' ADDED CODE
        End With

' Merge the active record
        .Execute Pause:=False
    End With

' Save then resulting document. NOTICE MODIFIED filename
    ActiveDocument.SaveAs2 FileName:="C:\Temp\" + DokName + ".docx", FileFormat:= _
        wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
        :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
        :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
        SaveAsAOCELetter:=False, CompatibilityMode:=14

' Close the resulting document
    ActiveWindow.Close

' Now, back in the template document, advance to next record
    ActiveDocument.MailMerge.DataSource.ActiveRecord = wdNextRecord
End Sub

回答by Hybrid

Thanks for that roryspop,

谢谢你的roryspop，

I ended up swapping the for loop with

我最终交换了 for 循环

Set Source = ActiveDocument

'The for loop was "To ActiveDocument.MailMerge.DataSource.RecordCount" but for
'some reason RecordCount returned -1 every time, so I set ActiveRecord 
'to wdLastRecord and then use that in the for loop.
ActiveDocument.MailMerge.DataSource.ActiveRecord = wdLastRecord

For i = 1 To ActiveDocument.MailMerge.DataSource.ActiveRecord
    ActiveDocument.MailMerge.DataSource.ActiveRecord = i
    Set Letter = Source.Range
        For Each oField In Letter.Fields

The rest of the code is the same, it's not very neat and I'm sure there must be a better way of doing things but it works.

其余的代码是相同的，它不是很整洁，我相信一定有更好的做事方式，但它有效。

回答by Ruut

The accepted solution did not work for me. I am using Word 2010. I managed to get a solution working and would like to share it here, so others can benefit from it:

接受的解决方案对我不起作用。我正在使用 Word 2010。我设法获得了一个解决方案，并想在这里分享它，以便其他人可以从中受益：

'purpose: save each letter generated after mail merge in a separate file
'         with the file name equal to first line of the letter.
'
'1. Before you run a mail merge make sure that in the main document you will 
'   end your letter with a Section Break (this can be found under 
'   Page Layout/Breaks/Section Break Next Page)
'2. Furthermore the first line of your letter contains the proposed file name
'   and put an enter after it. Make the font of the filename white, to make it 
'   is invisible to the receiver of the letter. You can also include a folder 
'   name if you like.
'3. Run the mail merge as usual. A file which contains all the letters is 
'   generated.
'4. Add this module to the generated mail merge file. Use Alt-F11 to go to the 
'   visual basic user interface, right click in the left pane on the generated
'   file and click on Import File and import this file
'5. save the generate file with all the letters as ‘Word Macro Enabled doc 
'   (*.docm)'.
'6. close the file.
'7. open the file again, click allow content when a warning about macro's is 
'   shown.
'8. execute the macro with the name SaveRecsAsFiles


Sub SaveRecsAsFiles()
    ' Convert all sections to Subdocs
    AllSectionsToSubDoc ActiveDocument
    'Save each Subdoc as a separate file
    SaveAllSubDocs ActiveDocument
End Sub

Private Sub AllSectionsToSubDoc(ByRef doc As Word.Document)
    Dim secCounter As Long
    Dim NrSecs As Long
    NrSecs = doc.Sections.Count
    'Start from the end because creating
    'Subdocs inserts additional sections
    For secCounter = NrSecs - 1 To 1 Step -1
        doc.Subdocuments.AddFromRange _
          doc.Sections(secCounter).Range
    Next secCounter
End Sub

Private Sub SaveAllSubDocs(ByRef doc As Word.Document)
    Dim subdoc As Word.Subdocument
    Dim newdoc As Word.Document
    Dim docCounter As Long
    Dim strContent As String, strFileName As String

    docCounter = 1
    'Must be in MasterView to work with
    'Subdocs as separate files
    doc.ActiveWindow.View = wdMasterView
    For Each subdoc In doc.Subdocuments
        Set newdoc = subdoc.Open
        'retrieve file name from first line of letter.
        strContent = newdoc.Range.Text
        strFileName = Mid(strContent, 1, InStr(strContent, Chr(13)) - 1)
        'Remove NextPage section breaks
        'originating from mailmerge
        RemoveAllSectionBreaks newdoc
        With newdoc
            .SaveAs FileName:=strFileName
            .Close
        End With
        docCounter = docCounter + 1
    Next subdoc
End Sub

Private Sub RemoveAllSectionBreaks(doc As Word.Document)
    With doc.Range.Find
        .ClearFormatting
        .Text = "^b"
        With .Replacement
            .ClearFormatting
            .Text = ""
        End With
        .Execute Replace:=wdReplaceAll
    End With
End Sub

Part of the code I copied from here

我从这里复制的部分代码