【Word VBA】差し込み印刷でレコード毎にPDFを保存するサンプル

WordのVBAを使用し、差し込み印刷でレコード毎にPDFを保存する方法の備忘録。Wordの差し込み印刷機能は、文章の一部を個別の名前等に変換して大量の文書を作成するのにとても便利です。それぞれのレコード単位で、PDFを作成、フィールドの名前で保存するVBAサンプルを作成してみました。

使用のWordは「Microsoft®Word® for Microsoft 365 MSO」（バージョン2311）です。

VBAサンプルの前提

このマクロを使用する前に、Word側で差し込み印刷の設定までは完了しておきます。複数の宛名が１枚に入る「ラベル」のような差し込み印刷には対応していません。

support.microsoft.com

参考サイト

基本の考え方は次の情報を参考にさせていただき「PDF保存」などアレンジしました。

www.wordvbalab.com

VBAサンプル

VBAコードのサンプルは次のとおり。

Option Explicit

Dim 差込印刷の文書 As Document
Dim フィールド一覧() As Variant
Dim ファイル名のフィールド As String
Dim レコード番号 As Long
Dim 終了レコード番号 As Long
Dim ファイル名 As String

Sub Wordの差し込み印刷でレコード毎にpdfで保存()

    Set 差込印刷の文書 = ActiveDocument
  
    '差込印刷の状況確認'
    If 差込印刷の文書.MailMerge.DataSource.Name = "" Then
        MsgBox "差込印刷の設定が完了していないため、マクロを終了します。"
        Exit Sub
    End If
    
    '保存ファイル名を設定'
    Call 差込印刷のフィールド名取得
    Call 保存時のファイル名にするフィールド取得
 
    With 差込印刷の文書.MailMerge
    
        '差込印刷の終了レコード番号取得'
        '一旦アクティブにしないと番号取得ができなかった'
        .DataSource.ActiveRecord = wdLastRecord
        終了レコード番号 = .DataSource.ActiveRecord
    
        '差込印刷の開始レコード番号をアクティブにする'
        .DataSource.ActiveRecord = wdFirstRecord
        レコード番号 = .DataSource.ActiveRecord
    
        'Wordの差し込み印刷側で、結果のプレビュー状態に設定'
        .ViewMailMergeFieldCodes = False

        Do 'ファイル保存を終了レコードまでループ'
  
            ファイル名 = .DataSource.DataFields(ファイル名のフィールド).Value
            If Not ファイル名 = "" Then
                差込印刷の文書.ExportAsFixedFormat _
                    OutputFileName:=差込印刷の文書.Path & "\" & ファイル名 & ".pdf", _
                    ExportFormat:=wdExportFormatPDF
            End If
       
            If レコード番号 = 終了レコード番号 Then
                Exit Do
            Else
                .DataSource.ActiveRecord = wdNextRecord
                レコード番号 = .DataSource.ActiveRecord
            End If
 
        Loop
 
    End With
  
    '終了処理'
    Set 差込印刷の文書 = Nothing
    MsgBox "完了しました。出力されたPDFが適切に変換できているかチェックしてください。"
 
End Sub

Function 差込印刷のフィールド名取得()
    Dim フィールド情報 As Object
    Dim i As Long
           
    ReDim Preserve フィールド一覧(差込印刷の文書.MailMerge.DataSource.DataFields.Count - 1) 'インデックスが0から開始なので1を引く

    'フィールド一覧の作成'
    For Each フィールド情報 In 差込印刷の文書.MailMerge.DataSource.FieldNames
        フィールド一覧(i) = フィールド情報.Name
        i = i + 1
    Next
            
End Function

Function 保存時のファイル名にするフィールド取得()
    ファイル名のフィールド = InputBox("ファイル名に使用するフィールド名を入力してください。" & vbCrLf & Join(フィールド一覧, " | "), "ファイル名の設定")

    '入力内容のチェック'
    Dim フィールドの有無確認用 As Variant
    フィールドの有無確認用 = Filter(フィールド一覧, ファイル名のフィールド)

    If UBound(フィールドの有無確認用) = -1 Then
        MsgBox "ファイル名に使用するフィールド名が存在しませんでした。半角全角等も含め確認してください。"
        End
    End If

End Function

補足説明・注意

Wordの動作が不安定な時がありました。原因が把握できていませんが、いずれにしもて、出力されたPDFが適切に保存されているかを必ずチェックが必要です。
このサンプルは、Wordの差し込み印刷で、「結果のプレビュー」をONにして、レコードを順番にプレビュー表示してPDFエクスポートを繰り返した事例です。
WdMailMergeActiveRecord 列挙は次のとおりです。

learn.microsoft.com
詳細確認できていないが、終了レコード番号について、DataSource.LastRecord で"-16"が返るだけで、DataSource.ActiveRecordのようにレコード番号が取得されなかった。そのため、DataSource.ActiveRecord = wdLastRecord で最終レコードをアクティブにしてDataSource.ActiveRecord でレコード番号を取得しています。

以上、WordのVBAを使用し、差し込み印刷でレコード毎にPDF保存する方法の備忘録でした。