2

ドキュメントをマージするときに、結果を個別のファイルに分割し、それぞれのファイルにマージ フィールド「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は知っていますが、ダイアログ ボックスは必要ありません。ワンクリック ボタンが必要です。

4

4 に答える 4

5

差し込み印刷テンプレート ドキュメントで、次のマクロ コードを " 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マージを終了する代わりに「 」オプションを選択します。これにより、マージされた個別のドキュメントが指定されたフォルダーに保存されます。

このコードはプロセッサに負荷をかける可能性があることに注意してください。

于 2015-03-19T20:38:43.280 に答える
4

結果のドキュメントを分割しない簡単な解決策があります: マージを準備し、テンプレート ドキュメントにとどまります。1 つのレコードをマージするときにマクロを記録し、結果のファイルを保存して閉じ、最終的に次のレコードに進みます。

以下の生成されたマクロを参照してください。データソース (テンプレート ドキュメントでアクセス可能) のフィールドからファイル名を抽出するためだけに、ごくわずかなコードを追加しました。

マクロをショートカット キーに割り当てるか、VBA でループを実装します。フィールド名は大文字と小文字が区別されることに注意してください。

よろしく、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
于 2013-07-07T11:34:11.740 に答える
1

そのroryspopをありがとう、

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

コードの残りの部分は同じです、それはあまりきれいではなく、物事を行うためのより良い方法があるはずですが、それは機能します。

于 2012-10-02T00:45:09.417 に答える
1

受け入れられた解決策は私にはうまくいきませんでした。私は 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

ここからコピーしたコードの一部

于 2013-03-22T16:21:49.103 に答える