WORD 差し込み印刷でレコード1件1ファィルで保存する方法

'===ポイント===
'レコードの移動は、MailMerge.DataSource.ActiveRecord の設定により行う
' MailMerge.DataSource.Included プロパティの設定により、差し込みデータに含むかどうか設定できる

Sub MakeResultFiles()

    ' ファィル名に使うキーとなるフィールド うちは学校なので学籍番号
    Const KeyField = "学籍番号"
    Dim FolderName As String
    FolderName = ThisDocument.Path & "\work\"

    Dim Last As Long
    Last = -1
    With ThisDocument.MailMerge.DataSource
        .SetAllIncludedFlags False
        .ActiveRecord = wdFirstDataSourceRecord
        
        While .ActiveRecord <> Last
            Last = .ActiveRecord

            .Included = True
            Dim StudentID As String
            StudentID = .DataFields(KeyField)
            
            ThisDocument.MailMerge.Execute
            Dim doc As Document
            Set doc = ActiveDocument
            
            Dim FileName As String
            'うちの場合 健康診断だったのでこんなファイル名にしました。
            FileName = "kenko" & StudentID & ".doc"
                        
            doc.SaveAs FolderName & FileName
            doc.Close
            .Included = False
            .ActiveRecord = wdNextDataSourceRecord
        Wend
        
        .SetAllIncludedFlags True
    End With
End Sub