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

これまでに、「【コード】差し込み印刷でレコード毎に別ファイルで保存」と「【コード】差し込み印刷でレコード毎に別ファイルで保存（その２）」を紹介してきました。

今回の改良で、チェックしたレコードのみを処理対象にできるようにしました。

ぜひお試しください。

このマクロでできること

差し込み印刷の対象としてチェックをつけたレコードだけを処理対象にします。チェックがないレコードはスキップされます。以下、Excelブックに入力したサンプルの名簿でレコードが選択されている状態を示しています。

作成するWord文書のファイル名をフィールドから指定できます。これまでのマクロでは、プログラム中に記述しましたが、今回は実行前にインプットボックスで指定します。

たとえばここでデータの中のフィールドの1つである「名前」と入力すると、この名前を用いてファイル名を作成します。先頭には通し番号が挿入されます。

マクロの解説

ファイル名に使用するフィールドを指定する

10行目～16行目で設定しています。

86行目以降に書かれているIsValidFieldNameファンクションを使い、入力したフィールド名が差し込み印刷のデータで実際に定義されているフィールドなのかを確認します。

チェックしたレコードのみを処理対象にする

実は、今回のマクロでDataSource.Includedプロパティを使い、チェックの入ったレコードのみを処理対象にしようとしましたが、うまくできませんでした。まだオブジェクトの仕組みを正確に理解できておりません。

なので、今回はエラー処理で切り抜けることにしました。

チェックが入っていないレコードを差し込み印刷しようとするとエラーが発生します。なので、エラーが発生しないときだけファイルを作成し（50行目～69行目）、エラーが発生したらエラーを解除して（71行目～76行目）次のレコードに進むという流れです。

マクロ

Sub 差し込み印刷_レコード毎に別ファイルで保存3()
　
　Dim myMainDoc As Document: Set myMainDoc = ActiveDocument
　
　With myMainDoc.MailMerge
　　
　　'-------------------------------------------
　　'ファイル名の指定
　　'-------------------------------------------
　　Dim myFieldName As String
　　myFieldName = InputBox("ファイル名に使用するフィールド名を入力してください。", _
　　　　　　　　　　　　　 "ファイル名の設定")
　　If IsValidFieldName(.DataSource.FieldNames, myFieldName) = False Then
　　　MsgBox "フィールド名が間違っています", vbExclamation
　　　Exit Sub
　　End If
　　
　　'-------------------------------------------
　　'差し込み印刷の設定
　　'-------------------------------------------
　　'新規文書に書き出す
　　.Destination = wdSendToNewDocument
　　
　　'空白の差し込みフィールドを印刷しない
　　.SuppressBlankLines = True
　　
　　'-------------------------------------------
　　'本処理
　　'-------------------------------------------
　　Dim i As Integer　　　　'レコード番号
　　
　　Dim iMax As Integer　　 '対象となる最終レコード番号（レコード数ではない）
　　.DataSource.ActiveRecord = wdLastRecord
　　iMax = .DataSource.ActiveRecord
　　
　　Dim j As Integer: j = 0 '作成したファイルの通し番号
　　
　　For i = 1 To iMax '全レコードを対象にループ処理
　　　
　　　'レコードの指定（1つのレコードに限定）
　　　With .DataSource
　　　　.FirstRecord = i
　　　　.LastRecord = i
　　　　.ActiveRecord = i
　　　End With
　
　　　On Error Resume Next
　　　.Execute
　　　
　　　If Err = 0 Then
　　　　'-------------------------------------------
　　　　'レコードが対象として選択されている場合：差し込み印刷を実行
　　　　'-------------------------------------------
　　　　j = j + 1
　　　　
　　　　Dim myFileName As String: myFileName = .DataSource.DataFields(myFieldName).Value
　　　　If myFileName = "" Then myFileName = "★" & myFieldName & "：不明★"
　　　　myFileName = j & "_" & myFileName 'ファイル名：通し番号+指定したフィールドの値
　　　　
　　　　'新規文書に名前をつけてdocx形式で保存
　　　　Dim myNewDoc As Document: Set myNewDoc = ActiveDocument
　　　　
　　　　myNewDoc.SaveAs FileName:=myMainDoc.Path & "\" & myFileName & ".docx", _
　　　　　　　　　　　　FileFormat:=wdFormatXMLDocument, _
　　　　　　　　　　　　AddToRecentFiles:=False
　　　　myNewDoc.Close
　　　　DoEvents
　　　　
　　　　Set myNewDoc = Nothing
　　　 
　　　Else
　　　　'-------------------------------------------
　　　　'レコードが対象として選択されていない場合：エラー発生
　　　　'-------------------------------------------
　　　　Err.Clear
　　　End If
　　　
　　Next i
　　
　End With
　
　Set myMainDoc = Nothing
　
End Sub

Function IsValidFieldName(myFieldNames As Object, myFieldName As String) As Boolean

　IsValidFieldName = False
　Dim myName As Object
　For Each myName In myFieldNames
　　If myName.Name = myFieldName Then
　　　IsValidFieldName = True
　　　Exit For
　　End If
　Next
　
End Function

関連記事

【コード】差し込み印刷でレコード毎に別ファイルで保存

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

同じキーワードの記事をお探しなら