【Wordマクロ】差し込み印刷でレコード毎に別ファイルで保存（その３）

以前紹介しました「【Wordマクロ】差し込み印刷でレコード毎に別ファイルで保存 」、「【Wordマクロ】差し込み印刷でレコード毎に別ファイルで保存（その２） 」に続いて、応用技を紹介します。

BIT-Aさんのセミナー を担当させていただいた時に、受講生から要望をいただきました。紹介するタイミングを逸しておりましたのでこの機会に。


このマクロもWordの差し込み印刷機能を使っています。ファイルの自動生成マクロです。

これまでに紹介したマクロと違うのは、フォルダ別に保存するということです。

フォルダ名は差し込み印刷に用いる宛先のリストの任意の項目を用いることができます。

分類して保存をする場合に便利ですね。


▼このマクロでできること

差し込み印刷で作成するWordファイルを、指定したフォルダ名と指定したファイル名で１つずつ保存します。

フォルダは、差し込み印刷のメイン文書が保存されているフォルダに作成されます。


▼マクロの解説

今までのマクロと同様、差し込み印刷の方法については説明を割愛させていただきます。

以下のマクロでは、「セミナー名」という項目をフォルダ名にしています。

ここは、任意の項目を選択できますので、差し込むデータにより使い分けてください。

赤文字部分でフォルダ作成をします。

.docx形式で保存しています。.doc形式での保存の場合は、少し修正が必要になります。

これまでの2つの記事をご覧ください。


▼マクロ

Sub 差し込み印刷_レコード毎に別ファイルで保存_フォルダ分け()

　Dim i As Integer
　Dim iMax As Integer
　Dim myName As String
　Dim myFolder As String
　Dim myFolderPath As String
　Dim myMainDoc As Document
　Dim myNewDoc As Document

　Set myMainDoc = ActiveDocument

　With myMainDoc.MailMerge

　　'レコード数の設定
　　iMax = .DataSource.RecordCount

　　'新規文書に書き出す
　　.Destination = wdSendToNewDocument

　　'空白の差し込みフィールドを印刷しない
　　.SuppressBlankLines = True

　　For i = 1 To iMax

　　　'レコードの指定
　　　With .DataSource
　　　　.ActiveRecord = i
　　　　.FirstRecord = i
　　　　.LastRecord = i
　　　End With
　　　
　　　'文書作成（差し込みエラー時に停止）
　　　.Execute Pause:=True
　
　　　'ファイル名に用いる文字列（項目名を設定してください）
　　　myName = .DataSource.DataFields("名前").Value
　　
　　　'フォルダ名に用いる文字列
　　　myFolder = .DataSource.DataFields("セミナー名").Value
　　
　　　'フォルダがない場合フォルダを作成
　　　myFolderPath = myMainDoc.Path & "\" & myFolder
　　　
　　　If Dir(myFolderPath, vbDirectory) = "" Then
　　　　MkDir Path:=myFolderPath
　　　End If
　　
　　　'新規文書に名前をつけて保存
　　　Set myNewDoc = ActiveDocument
　　　If myName <> "" Then
　　　　myNewDoc.SaveAs _
　　　　　FileName:=myFolderPath & "\" & myName & ".docx", _
　　　　　FileFormat:=wdFormatXMLDocument, _
　　　　　AddToRecentFiles:=False
　　　　myNewDoc.Close
　　　End If
　　　DoEvents
　
　　Next i

　End With

　Set myMainDoc = Nothing
　Set myNewDoc = Nothing

End Sub


▼関連記事

【Wordマクロ】差し込み印刷でレコード毎に別ファイルで保存　.doc形式で保存

【Wordマクロ】差し込み印刷でレコード毎に別ファイルで保存（その２） 　.docx 形式で保存