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