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

セミナー受講生から、差し込み印刷に関する質問をいただきました。

例えば、100個のレコードを用いて差し込み印刷の「個々のドキュメントの編集」を実行する場合、1つのファイルにセクション区切りされた100個のレコードが作られます。

個別にファイルに保存するとなると、セクションごとに内容をコピペしなければならず大変な作業になります。

その対応策として、ネット上にはいろいろマクロが紹介されているようです。やっぱりこの手のことは必要ですね。

今回、私も1つ作ってみました。

このマクロでできること

差し込み印刷用のメイン文書に宛先のリスト(Excelファイルなど)が設定されている状態でマクロを実行します。

すると、このリストに掲載されたレコードをすべて差し込んだファイルが作成されます。

作成されるファイルは、フィールド名(又は、Excelファイルの列名)の”名前”に記載された値をファイル名とします。

メイン文書と同じフォルダにファイルが保存されます。

作成したファイルをすべて閉じます。

マクロの解説

37行目で保存用のファイル名を設定しています。

46行目でファイルを閉じます。開いたままにする場合にはこの項目を削除してください。

26行~31行を修正しました。(2014/03/09)

マクロ


Sub 差し込み印刷_レコード毎に別ファイルで保存()
 
 Dim i As Integer
 Dim iMax As Integer
 Dim myName As String
 Dim myMainDoc As Document
 Dim myNewDoc As Document
  
 Set myMainDoc = ActiveDocument
 
 With myMainDoc.MailMerge
  
  'レコード数の設定
  .DataSource.ActiveRecord = wdLastRecord
  iMax = .DataSource.ActiveRecord
  
  '新規文書に書き出す
  .Destination = wdSendToNewDocument
  
  '空白の差し込みフィールドを印刷しない
  .SuppressBlankLines = True
  
  For i = 1 To iMax

   'レコードの指定
   '.DataSource.ActiveRecord = i '削除しました。
   With .DataSource
    .FirstRecord = i
    .LastRecord = i
    .ActiveRecord = i '追加しました。誤記を失礼しました。
   End With
   
   '文書作成(差し込みエラー時に停止)
   .Execute Pause:=True
   
   'ファイル名に用いる文字列(項目名を設定してください)
   myName = .DataSource.DataFields("名前").Value
   
   '新規文書に名前をつけて保存
   Set myNewDoc = ActiveDocument
   If myName <> "" Then
    myNewDoc.SaveAs FileName:=myMainDoc.Path & "\" & _
            myName & ".doc", _
            FileFormat:=wdFormatDocument, _
            AddToRecentFiles:=False
    myNewDoc.Close
   End If
   DoEvents
   
  Next i
 
 End With
 
 Set myMainDoc = Nothing
 Set myNewDoc = Nothing
  
End Sub

トップへ戻る