Word、VLOOKUP不要のエクセルからエクセルへ差し込み印刷（連続印刷）ができるマクロ
差し込み印刷のマクロを組む過程を段階別にコード化しました。単一の差し込みから複数絞り込みの差し込みまで、8種類のパターンを用意しています。マクロ初心者でもコピペで実装できます。
仕事の仕様にあった差し込み印刷のベースになるサンプルがきっと見つかります。是非、コピペして動きを確かめてください。
マクロ初心者の人でも分かるように手順を図説しています。難易度も表しているのでご自身のスキルに合わせて是非、差し込み印刷を実装してみてください。
マクロ実行前の準備
普段マクロを利用していない人は公式リファレンスを読んでマクロのセキュリティレベルを全てのマクロを有効にするに変更してください。
シートを2つ準備して下さい。Sheet1がテーブルデータ、Sheet2が印刷用シートです。
差し込むデータはSheet1にテーブル状で入力されているものとします（1列でも可）。1行目にフィールド名、2行目以降がレコード（データ）です。空レコード（行全て空白）は禁止です。
（クリックで画像が拡大します）
事前準備としてマクロの実行ができるように開発タブを表示して下さい。
ファイル→オプション→リボンのユーザー設定で開発のチェックボックスをオンにします。
開発タブでVisual BasicアイコンをクリックするとVBE（VisualBasicEditor）が表示されます。
ショートカットはAlt+F11です。
VBEメニューの挿入から標準モジュールをクリックします。これでコードを貼り付ける準備は完了です。
プロジェクトウィンドウ内の各シートをクリックし、それぞれプロパティウィンドウ内のオブジェクト名をSheet1はwsData、Sheet2はwsPrintとします。
これで準備は完了です。後は実装したい差し込み印刷を選んでください。
フィールド単位で差し込むマクロ/難易度:簡単
Sheet1 B列のデータをSheet2 A1セルに差し込んで印刷します。テンプレートに名前だけ差し込んで印刷する場合はこのマクロがおすすめです。VLOOKUP関数をわざわざ使う必要はありません。
下のコードをコピーします。コード右上のボタンでコピーできます。Modul1をダブルクリックし、コピーしたコードをコードウィンドウ（画像右側部分）へ貼り付けます。
VBE画面を画面右上の×で閉じてください。
Public Sub 差し込み印刷_B列のみ()
Dim r As Variant
With wsData '※1
For Each r In .Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp)) '※2
With wsPrint '※1
.Range("A1") = r.Value '※3
.PrintPreview '運用時はPrintOutに変更推奨 '※4
End With
Next r
End With
End Sub- 4,6行目…wsData,wsPrintはシート名ではなくオブジェクト名です。詳細は割愛しますが色々便利になります。
- 5行目…テーブルB列のデータを印刷シートに差し込みます。Cells(r, c)とCells(.Rows.Count,c)のcで差し込むデータの列を変更できます。A列を差し込みたい場合は.Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))にします。
- 7行目….Range(“A1”)で差し込み先のセルを指定しています。変更したい場合はA1の部分を変更して下さい。B2セルに差し込む場合は.Range(“B2”)とします。
- 8行目…テスト印刷が完了して運用を開始する場合、印刷プレビューが不要ならこの行を.PrintPreviewから.PrintOutに変更して下さい。プレビューなしで印刷されます。
開発タブのマクロアイコンをクリックするとダイアログが現れます。差し込み印刷_B列のみを選択し、実行ボタンを押すとマクロが実行されます。
ショートカットはAlt+F8です。
差し込み印刷に連番を付与するマクロ/難易度:簡単
前項のコードに連番付与の処理を追加しました。Sheet2に連番＋レコードを差し込みます。
下のコードをコピーします。コード右上のボタンでコピーできます。Modul1をダブルクリックし、コピーしたコードをコードウィンドウ（画像右側部分）へ貼り付けます。
VBE画面を画面右上の×で閉じてください。
Public Sub 差し込み印刷_B列のみ_連番付与()
Dim r As Variant
Dim 連番 As Long '※1
With wsData
For Each r In .Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp)) '※2
連番 = 連番 + 1 '※1
With wsPrint
.Range("A1") = 連番 '※3
.Range("B1") = r.Value '※3
.PrintPreview '運用時はPrintOutに変更推奨 '※4
End With
Next r
End With
End Sub- 3,7行目…連番用に変数を用意、差し込みを繰り返す処理の中で、変数に1をプラスすれば連番になります。
- 6行目…テーブルB列のデータを印刷シートに差し込みます。Cells(r, c)とCells(.Rows.Count,c)のcで差し込むデータの列を変更できます。A列を差し込みたい場合は.Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))にします。
- 9,10行目….Range(“A1”)で差し込み先のセルを指定しています。変更したい場合はA1の部分を変更して下さい。B2セルに差し込む場合は.Range(“B2”)とします。
- 11行目…テスト印刷が完了して運用を開始する場合、印刷プレビューが不要ならこの行を.PrintPreviewから.PrintOutに変更して下さい。プレビューなしで印刷されます。
開発タブのマクロアイコンをクリックするとダイアログが現れます。差し込み印刷_B列のみ_連番付与を選択し、実行ボタンを押すとマクロが実行されます。
ショートカットはAlt+F8です。
差し込み印刷をレコード単位で行うマクロ/難易度:簡単
レコード（行）単位で差し込んで印刷します。Sheet2の1行目にレコードごと差し込むので、2行目以降に印刷用のフォームを作成し、差し込まれたレコードをリンクさせます。
1行目にレコードが差し込まれるので、2行目以降で印刷範囲を指定して下さい。必要なフィールドを印刷範囲内でリンクさせます。
（クリックで画像が拡大します）
下のコードをコピーします。コード右上のボタンでコピーできます。Modul1をダブルクリックし、コピーしたコードをコードウィンドウ（画像右側部分）へ貼り付けます。
VBE画面を画面右上の×で閉じてください。
Public Sub 差し込み印刷_レコード単位()
Dim r As Variant
With wsData.Range("A1").CurrentRegion '※1
For Each r In .Offset(1, 0).Resize(.Rows.Count - 1 , .Columns.Count).Rows '※1
With wsPrint
r.Copy .Range("A1")
.PrintPreview '運用時はPrintOutに変更推奨 '※2
End With
Next r
End With
End Sub- 4~5行目…範囲指定方法が複雑なのでざっくり図説します。
- 8行目…テスト印刷が完了して運用を開始する場合、印刷プレビューが不要ならこの行を.PrintPreviewから.PrintOutに変更して下さい。プレビューなしで印刷されます。
開発タブのマクロアイコンをクリックするとダイアログが現れます。差し込み印刷_レコード単位を選択し、実行ボタンを押すとマクロが実行されます。
ショートカットはAlt+F8です。
差し込むレコードを指定するマクロ/難易度:簡単
Sheet1のA列に指定用の列を追加して下さい。A列に1が入力されている場合、その行が差し込まれます。入力が全く無い場合は、全てのレコードを印刷します。
1行目にレコードが差し込まれるので、2行目以降で印刷範囲を指定して下さい。必要なフィールドを印刷範囲内でリンクさせます。
（クリックで画像が拡大します）
Sheet1のA列に指定用の列を追加して下さい。
下のコードをコピーします。コード右上のボタンでコピーできます。Modul1をダブルクリックし、コピーしたコードをコードウィンドウ（画像右側部分）へ貼り付けます。
VBE画面を画面右上の×で閉じてください。
Public Function オートフィルター基点() As Range '※1
Set オートフィルター基点 = wsData.Range("A1")
End Function
Public Sub 差し込み印刷_指定()
Dim r As Variant
With wsData
If .AutoFilterMode = True Then オートフィルター基点.AutoFilter '※2
If .Cells(.Rows.Count, 1).End(xlUp).Row <> 1 Then オートフィルター基点.AutoFilter 1, 1 '※3
With オートフィルター基点.CurrentRegion
For Each r In .Offset(1, 1).Resize(.Rows.Count - 1, Columns.Count - 1).SpecialCells(xlCellTypeVisible).Rows '※4
With wsPrint
r.Copy .Range("A1")
.PrintPreview '運用時はPrintOutに変更推奨 '※5
End With
Next r
End With
If .AutoFilterMode = True Then オートフィルター基点.AutoFilter
End With
End Sub- 1~3行目…メンテ性を考慮して、定数で指定したいのですが、RangeオブジェクトはConstで指定できません。オブジェクトを返す関数にしてごまかしています。
- 9行目…オートフィルターのON/OFFを判定しています。ONの状態で以降のマクロを実行すると狙った動きにならないので必ずOFFにするようにしています。
- 10行目…A列の入力有無を確認しています（最下行からCtrl+↑を実行し、1行目でなかったら入力ありと判定する）。入力がある場合のみ、オートフィルターを実行します。
- 13行目…前項のコードと指定方法が若干違います。追加列があるのでOffset値とResize値が変わっています。
- 16行目…テスト印刷が完了して運用を開始する場合、印刷プレビューが不要ならこの行を.PrintPreviewから.PrintOutに変更して下さい。プレビューなしで印刷されます。
エラーについて…指定列に1以外の数値・文字列を入力するとエラーになります。エラーを防ぐのであれば、後述するWorksheetオブジェクトのAutoFilterプロパティを使ってオートフィルター実施後の抽出数をカウントするか、全ての数字・文字列を抽出条件に指定するオートフィルター基点.AutoFilter 1, “<>”のがお手軽です。
開発タブのマクロアイコンをクリックするとダイアログが現れます。差し込み印刷_指定を選択し、実行ボタンを押すとマクロが実行されます。
ショートカットはAlt+F8です。
差し込みからレコードを除外するマクロ/難易度:簡単
Sheet1のB列に指定用の列を追加して下さい。B列に2が入力されている場合、その行は差し込まれません。指定と除外の優先順位は「指定<除外」です。
1行目にレコードが差し込まれるので、2行目以降で印刷範囲を指定して下さい。必要なフィールドを印刷範囲内でリンクさせます。
（クリックで画像が拡大します）
Sheet1のA,B列に指定,除外の列を追加して下さい。
下のコードをコピーします。コード右上のボタンでコピーできます。Modul1をダブルクリックし、コピーしたコードをコードウィンドウ（画像右側部分）へ貼り付けます。
VBE画面を画面右上の×で閉じてください。
Public Function オートフィルター基点() As Range
Set オートフィルター基点 = wsData.Range("A1")
End Function
Public Sub 差し込み印刷_指定除外()
Dim r As Variant
Dim 差込件数 As Long
Application.GoTo オートフィルター基点, True '※1
With wsData
If .AutoFilterMode = True Then オートフィルター基点.AutoFilter
If .Cells(.Rows.Count, 1).End(xlUp).Row <> 1 Then オートフィルター基点.AutoFilter 1, 1
オートフィルター基点.AutoFilter 2, "<>2" '※2
差込件数 = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1 '※3
End With
If 差込件数 = 0 Then '※4
MsgBox "印刷対象がありません"
GoTo 後処理
End If
If vbNo = MsgBox("印刷するレコードは " & 差込件数 & "件です。印刷を始めます", vbYesNo) Then '※5
MsgBox "印刷を中止します"
GoTo 後処理
End If
Application.ScreenUpdating = False
With オートフィルター基点.CurrentRegion
For Each r In .Offset(1, 2).Resize(.Rows.Count - 1, Columns.Count - 2).SpecialCells(xlCellTypeVisible).Rows
With wsPrint
r.Copy .Range("A1")
.PrintPreview '運用時はPrintOutに変更推奨 '※6
End With
Next r
End With
MsgBox "印刷が終わりました"
後処理: '※7
オートフィルター基点.AutoFilter
Application.ScreenUpdating = True
End Sub- 9行目…レコード件数が多いと、オートフィルター実行時に、フィールド名（1行目）が見えなくなるのでその対策です。
- 14行目…B列に2が入力されている場合、そのレコードは抽出されません。
- 15行目…SpecialCells(xlCellTypeVisible)で可視セル（＝オートフィルターで絞り込んだデータ）を指定、フィルターの抽出件数をカウントしています。
- 18~21行目…抽出件数がゼロの場合、以降の処理をスキップします。
- 23~26行目…ダイアログで印刷する/しないを選択します。Noを選択した場合、以降の処理をスキップします。
- 34行目…テスト印刷が完了して運用を開始する場合、印刷プレビューが不要ならこの行を.PrintPreviewから.PrintOutに変更して下さい。プレビューなしで印刷されます。
- 41行目…この行までスキップします。
15行目のAutoFilterは、WorksheetオブジェクトのAutoFilterプロパティです。その他のAutoFilterは、RangeオブジェクトのAutoFilterメソッドです。混同しないように注意して下さい。
開発タブのマクロアイコンをクリックするとダイアログが現れます。差し込み印刷_指定除外を選択し、実行ボタンを押すとマクロが実行されます。
ショートカットはAlt+F8です。
差し込むレコードを指定のフィールドで絞り込むマクロ/難易度:普通
レコードをフィールドデータで絞り込んで差し込みます。絞り込み用にユーザーフォームを用意します。
1行目にレコードが差し込まれるので、2行目以降で印刷範囲を指定して下さい。必要なフィールドを印刷範囲内でリンクさせます。
（クリックで画像が拡大します）
挿入→ユーザーフォームでフォームを作成し、表示→ツールボックスでリストボックスを選択、フォーム内に適当なサイズで作成します。フォントはプロパティウィンドウで調整して下さい。
前項のListBox1をダブルクリックするとコードが現れますが削除します。下のコードをコピーし（コード右上のボタンでコピーできます）、コピーしたコードをコードウィンドウへ貼り付けます。
Private Sub UserForm_Initialize()
Dim dicオブジェクト As Object, キー As Variant, r As Variant
Dim i As Long
Dim 一時データ As String
With wsData
If .AutoFilterMode = True Then オートフィルター基点.AutoFilter '※1
Set dicオブジェクト = CreateObject("Scripting.Dictionary") '※2
If .Cells(Rows.Count, 列指定).End(xlUp).Row = 1 Then Exit Sub '列指定はパブリック変数…Module1参照
For Each r In .Range(.Cells(2, 列指定), .Cells(Rows.Count, 列指定).End(xlUp))
If r.Value <> "" Then
一時データ = r.Value
If Not dicオブジェクト.Exists(一時データ) Then
dicオブジェクト.Add 一時データ, 一時データ
End If
End If
Next r
End With
キー = dicオブジェクト.keys
For i = 0 To dicオブジェクト.Count - 1
ListBox1.AddItem キー(i)
Next i
Set dicオブジェクト = Nothing
ListBox1.ListIndex = 0
End Sub- 7行目…オートフィルターのON/OFFを判定しています。ONの状態で以降のマクロを実行すると全てのデータを抽出できないので必ずOFFにするようにしています。
- 8行目…ListBox1にデータを代入するのにDictionaryオブジェクトを使用して重複データを削除しています。
リストボックスについてはこの記事で詳しく紹介しています。
CreateObject関数を使用していますが、マクロ経験のある人は参照設定推奨です。
ユーザーフォームの表示/非表示切替はBookモジュールで行います。Sheet1がアクティブになった時（ブックが開いた時含む）に表示、アクティブでなくなった時に非表示にします。
下のコードをコピーします。コード右上のボタンでコピーできます。ThisWorkbookをダブルクリックし、コピーしたコードをコードウィンドウ（画像右側部分）へ貼り付けます。
Private Sub Workbook_Open()
If ActiveSheet.CodeName = "wsData" Then UserForm1.Show vbModeless
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object) '※1
If Sh.CodeName = "wsData" Then UserForm1.Show vbModeless
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object) '※1
If Sh.CodeName = "wsData" Then UserForm1.Hide
End Sub- 5,9行目…イベントWorkbook_SheetActivateとWorkbook_SheetDeactivateの引数Shはアクティブシートを返します。
下のコードをコピーします。コード右上のボタンでコピーできます。Modul1をダブルクリックし、コピーしたコードをコードウィンドウ（画像右側部分）へ貼り付けます。
VBE画面を画面右上の×で閉じてください。
Public Const 列指定 As Long = 10 '※1
Public Function オートフィルター基点() As Range
Set オートフィルター基点 = wsData.Range("A1")
End Function
Public Sub 差し込み印刷_レコード単位()
Dim r As Variant
Dim 差込件数 As Long
Application.GoTo オートフィルター基点, True
With wsData
If .AutoFilterMode = True Then オートフィルター基点.AutoFilter
オートフィルター基点.CurrentRegion.AutoFilter 列指定, UserForm1.ListBox1.Value '※2
差込件数 = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
If vbNo = MsgBox("印刷するレコードは " & 差込件数 & "件です。印刷を始めます", vbYesNo) Then
MsgBox "印刷を中止します"
GoTo 後処理
End If
Application.ScreenUpdating = False
With オートフィルター基点.CurrentRegion
For Each r In .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).SpecialCells(xlCellTypeVisible).Rows
With wsPrint
r.Copy .Range("A1")
.Activate '※3
.PrintPreview '運用時はPrintOutに変更推奨 '※4
End With
Next r
End With
MsgBox "印刷が終わりました"
後処理:
.Activate '※3
オートフィルター基点.AutoFilter
Application.ScreenUpdating = True
End With
End Sub- 1行目…メンテ性を考慮して定数で指定しています。絞り込みたい列を指定して下さい（A列なら1、B列なら2）。スクショサンプルのテーブルだと守備列の重複を削除したデータがリストボックスに並びます。
- 15行目…リストボックスで選択したデータを絞り込みます。
- 29,38行目…これがないとマクロ終了後にユーザーフォームが再表示されません（代わりにEnd Sub手前にUserForm1.show VbModelessでも動きます）。
- 30行目…テスト印刷が完了して運用を開始する場合、印刷プレビューが不要ならこの行を.PrintPreviewから.PrintOutに変更して下さい。プレビューなしで印刷されます。
リストから絞り込むデータを選択します。
開発タブのマクロアイコンをクリックするとダイアログが現れます。差し込み印刷_レコード単位を選択し、実行ボタンを押すとマクロが実行されます。
差し込むレコードを指定,除外,絞り込むマクロ/難易度:難しい
今までのコードを組み合わせたものです。前項のコードは絞り込みをする前提のコードですが、本コードは全てのレコードを印刷する、レコードを絞り込んで印刷する、指定レコードのみ印刷するの3パターンを選択できます。
ユーザーフォームは、パターン選択用のオプションボタンとその他の処理用にコマンドボタンを追加しています。
難易度的にマクロ経験がある程度ないと実装は難しいです。経験者前提で図説・解説も端折っています。
1行目にレコードが差し込まれるので、2行目以降で印刷範囲を指定して下さい。必要なフィールドを印刷範囲内でリンクさせます。
（クリックで画像が拡大します）
テーブルはレコードを除外して差し込みと同じテーブル（2列追加したもの）を用意して下さい。
スクリーンショットを参考にしてユーザーフォームを作成して下さい。
Private Sub CommandButton1_Click() '※1
Call 差し込み印刷_3モード
End Sub
Private Sub CommandButton2_Click() '※2
ListBox1.Clear
Call UserForm_Initialize
End Sub
Private Sub ListBox1_AfterUpdate() '※3
OptionButton2 = True
End Sub
Private Sub OptionButton1_AfterUpdate()
ListBox1.ListIndex = -1
End Sub
Private Sub OptionButton2_AfterUpdate()
ListBox1.ListIndex = 0
End Sub
Private Sub OptionButton3_AfterUpdate()
ListBox1.ListIndex = -1
End Sub
Private Sub UserForm_Initialize()
Dim dicオブジェクト As Object, キー As Variant, r As Variant
Dim i As Long
Dim 一時データ As String
With wsData
OptionButton1 = True
If .AutoFilterMode = True Then オートフィルター基点.AutoFilter
If .Cells(Rows.Count, 列指定).End(xlUp).Row = 1 Then GoTo nolist '※4
Set dicオブジェクト = CreateObject("Scripting.Dictionary")
For Each r In .Range(.Cells(2, 列指定), .Cells(Rows.Count, 列指定).End(xlUp))
If r.Value <> "" Then
一時データ = r.Value
If Not dicオブジェクト.Exists(一時データ) Then
dicオブジェクト.Add 一時データ, 一時データ
End If
End If
Next r
End With
キー = dicオブジェクト.keys
For i = 0 To dicオブジェクト.Count - 1
ListBox1.AddItem キー(i)
Next i
Set dicオブジェクト = Nothing
OptionButton2.Enabled = True
Exit Sub
nolist:
OptionButton2.Enabled = False
End Sub- 1~3行目…マクロ実行ボタンです。
- 5~8行目…レコード更新時に絞り込み用のリストボックスを更新できるよう、ボタンを追加しました（Worksheet_Changeイベントを使用すれば自動処理も可能です）。
- 10~24行目…オプションボタンの挙動を指定しています。
- 34行目…絞り込み用データの有無を判定しています。データが無い場合はリストボックスをグレーアウト(Enabled = False）します。
Bookモジュールは前項のコードと同じです。
Private Sub Workbook_Open()
If ActiveSheet.CodeName = "wsData" Then UserForm1.Show vbModeless
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh.CodeName = "wsData" Then UserForm1.Show vbModeless
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
If Sh.CodeName = "wsData" Then UserForm1.Hide
End SubPublic Const 列指定 As Long = 12 '※1
Public Function オートフィルター基点() As Range
Set オートフィルター基点 = wsData.Range("A1")
End Function
Public Sub 差し込み印刷_3モード()
Dim r As Variant
Dim i As Long, 差込件数 As Long
Application.Goto オートフィルター基点, True
With wsData
If .AutoFilterMode = True Then オートフィルター基点.AutoFilter
For i = 1 To オートフィルター基点.CurrentRegion.Columns.Count
オートフィルター基点.AutoFilter i, VisibleDropDown:=False '※2
Next i
Select Case True '※3
Case UserForm1.OptionButton3
If .Cells(.Rows.Count, 1).End(xlUp).Row = 1 Then
MsgBox "レコードが指定されていません" & vbCrLf & "A列に「1」を入力して指定して下さい"
Exit Sub
End If
オートフィルター基点.AutoFilter 1, 1, VisibleDropDown:=True '※2
Case UserForm1.OptionButton2
オートフィルター基点.AutoFilter 列指定, UserForm1.ListBox1.Value, , VisibleDropDown:=True '※2
End Select
If .Cells(.Rows.Count, 2).End(xlUp).Row <> 1 Then オートフィルター基点.AutoFilter 2, "<>2", VisibleDropDown:=True '※2
差込件数 = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
Select Case True
Case 差込件数 = 0
MsgBox "印刷対象がありません"
GoTo 後処理
Case vbNo = MsgBox("印刷するレコードは " & 差込件数 & "件です。印刷を始めます", vbYesNo)
MsgBox "印刷を中止します"
GoTo 後処理
End Select
Application.ScreenUpdating = False
With オートフィルター基点.CurrentRegion
For Each r In .Offset(1, 2).Resize(.Rows.Count - 1, .Columns.Count - 2).SpecialCells(xlCellTypeVisible).Rows
With wsPrint
r.Copy .Range("A1")
.Activate
.PrintPreview '運用時はPrintOutに変更推奨 '※4
End With
Next r
End With
MsgBox "印刷が終わりました"
後処理:
.Activate
オートフィルター基点.AutoFilter
Application.ScreenUpdating = True
End With
End Sub- 1行目…メンテ性を考慮して定数で指定しています。絞り込みたい列を指定して下さい（A列なら1、B列なら2）。スクショサンプルのテーブルだと守備列の重複を削除したデータがリストボックスに並びます。
- 17,26,28,31行目…絞り込みが有効な列のみフィルタボタンを表示する処理です。全てのボタンを一度非表示にし、絞り込みを実行した列のみ再表示しています。
- 20～29行目…Select Caseステートメントでオプションボタンを処理しています。オプションボタンはグループの中で複数選択することができません（単一選択）。機能的にはコンボボックスやリストボックスと同じですが、今回はユーザーインターフェース的に有利なので採用しました。
- 51行目…テスト印刷が完了して運用を開始する場合、印刷プレビューが不要ならこの行を.PrintPreviewから.PrintOutに変更して下さい。プレビューなしで印刷されます。
1枚に複数のレコードを差し込むマクロ/難易度:難しい
このコードは差し込む件数を設定できます。1枚の帳票にレコードを複数差し込めます。1枚の用紙に複数名記入させるような帳票に使います。人数が割り切れない場合、最終ページで0を差し込んで最後まで埋める仕様です。
難易度的にマクロ経験がある程度ないと実装は難しいです。経験者前提で図説・解説も端折っています。
指定した件数分、差し込んで印刷します。印刷最終ページで空データがある場合（レコード件数が指定件数で割り切れない場合）、リンクだと0表示されます。非表示にしたい場合はIF関数や書式設定で回避して下さい。
（クリックで画像が拡大します）
レコード挿入列と印刷フォームの間を1行以上開けて下さい。スクショサンプルの場合、マクロを実行すると最初の8件を差し込みます。次の8件を差し込む前に最初の8件をクリアしますが、その時レコードと印刷フォームが連続していると印刷フォームも一緒にクリアされてしまいます。
テーブルはレコードを除外して差し込みと同じテーブル（2列追加したもの）を用意して下さい。
スクリーンショットを参考にしてユーザーフォームを作成して下さい。
Formモジュールは前項と同じです。
Private Sub CommandButton1_Click()
Call 差し込み印刷_3モード_差し込み件数可変
End Sub
Private Sub CommandButton2_Click()
ListBox1.Clear
Call UserForm_Initialize
End Sub
Private Sub ListBox1_AfterUpdate()
OptionButton2 = True
End Sub
Private Sub OptionButton1_AfterUpdate()
ListBox1.ListIndex = -1
End Sub
Private Sub OptionButton2_AfterUpdate()
ListBox1.ListIndex = 0
End Sub
Private Sub OptionButton3_AfterUpdate()
ListBox1.ListIndex = -1
End Sub
Private Sub UserForm_Initialize()
Dim dicオブジェクト As Object, キー As Variant, r As Variant
Dim i As Long
Dim 一時データ As String
With wsData
OptionButton1 = True
If .AutoFilterMode = True Then オートフィルター基点.AutoFilter
If .Cells(Rows.Count, 列指定).End(xlUp).Row = 1 Then GoTo nolist
Set dicオブジェクト = CreateObject("Scripting.Dictionary")
For Each r In .Range(.Cells(2, 列指定), .Cells(Rows.Count, 列指定).End(xlUp))
If r.Value <> "" Then
一時データ = r.Value
If Not dicオブジェクト.Exists(一時データ) Then
dicオブジェクト.Add 一時データ, 一時データ
End If
End If
Next r
End With
キー = dicオブジェクト.keys
For i = 0 To dicオブジェクト.Count - 1
ListBox1.AddItem キー(i)
Next i
Set dicオブジェクト = Nothing
OptionButton2.Enabled = True
Exit Sub
nolist:
OptionButton2.Enabled = False
End SubBookモジュールも前項と同じものです。
Private Sub Workbook_Open()
If ActiveSheet.CodeName = "wsData" Then UserForm1.Show vbModeless
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh.CodeName = "wsData" Then UserForm1.Show vbModeless
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
If Sh.CodeName = "wsData" Then UserForm1.Hide
End SubPublic Const 列指定 As Long = 12 '※1
Public Const 件数指定 As Long = 8 '※2
Public Const プレビュー指定 As Boolean = True '※3
Public Function オートフィルター基点() As Range
Set オートフィルター基点 = wsData.Range("A1")
End Function
Public Function 差込位置() As Range '※4
Set 差込位置 = wsPrint.Range("A1")
End Function
Public Sub 差し込み印刷_3モード_差し込み件数可変()
Dim r As Variant
Dim i As Long, 差込件数 As Long, 差込回数 As Long, 差込行 As Long '※5
Application.Goto オートフィルター基点, True
With wsData
If .AutoFilterMode = True Then オートフィルター基点.AutoFilter
For i = 1 To オートフィルター基点.CurrentRegion.Columns.Count
オートフィルター基点.AutoFilter i, VisibleDropDown:=False
Next i
Select Case True
Case UserForm1.OptionButton3
If .Cells(.Rows.Count, 1).End(xlUp).Row = 1 Then
MsgBox "レコードが指定されていません" & vbCrLf & "A列に「1」を入力して指定して下さい"
Exit Sub
End If
オートフィルター基点.AutoFilter 1, 1, VisibleDropDown:=True
Case UserForm1.OptionButton2
オートフィルター基点.AutoFilter 列指定, UserForm1.ListBox1.Value, , VisibleDropDown:=True
End Select
If .Cells(.Rows.Count, 2).End(xlUp).Row <> 1 Then オートフィルター基点.AutoFilter 2, "<>2", VisibleDropDown:=True
差込件数 = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
Select Case True
Case 差込件数 = 0
MsgBox "印刷対象がありません"
GoTo 後処理
Case vbNo = MsgBox("印刷するレコードは " & 差込件数 & "人です。印刷を始めます", vbYesNo)
MsgBox "印刷を中止します"
GoTo 後処理
End Select
Application.ScreenUpdating = False
wsPrint.Activate
With オートフィルター基点.CurrentRegion
For Each r In .Offset(1, 2).Resize(.Rows.Count - 1, .Columns.Count - 2).SpecialCells(xlCellTypeVisible).Rows
With wsPrint
差込回数 = 差込回数 + 1 '※6
差込行 = 差込行 + 1
r.Copy .Cells(差込行, 1)
If 差込行 Mod 件数指定 = 0 Then
If 差込回数 = 件数指定 Then
.PrintOut preview:=True
Else
.PrintOut preview:=プレビュー指定
End If
差込位置.CurrentRegion.Clear
差込行 = 0
End If
Select Case True '※7
Case 差込回数 = 差込件数 And 差込件数 < 件数指定
.PrintOut preview:=True
差込位置.CurrentRegion.Clear
Case 差込回数 = 差込件数 And 差込回数 Mod 件数指定 <> 0
.PrintOut preview:=プレビュー指定
差込位置.CurrentRegion.Clear
End Select
End With
Next r
End With
MsgBox "印刷が終わりました"
後処理:
.Activate
オートフィルター基点.AutoFilter
Application.ScreenUpdating = True
End With
End Sub- 1行目…メンテ性を考慮して定数で指定しています。絞り込みたい列を指定して下さい（A列なら1、B列なら2）。スクショサンプルのテーブルだと守備列の重複を削除したデータがリストボックスに並びます。
- 2行目…差し込み件数をここで指定します。
- 3行目…印刷1枚目は必ずプレビューを表示、2枚目以降はプレビューあり/なしを選択できるようにしました。2枚目以降はプレビューなしで印刷する場合、ここをFalseに変更して下さい。
- 9~11行目…コード上、指定する回数が多くなったので可読性を上げるための関数化です（定数風）。
- 15行目…差し込み件数を設定する処理の為、変数を2つ増やしました。差込回数はレコードを差し込んだ回数、差込行は差し込むレコードの行を指定しています。
- 57~68行目…印刷1ページ目から最終ページ手前までの処理です。レコードを順次差し込み、差し込み件数指定値で除して余りがゼロになるまで差し込みを繰り返し、ゼロになったら印刷実行→差し込んだデータをクリアします。2枚目以降の印刷プレビュー指定用に、印刷が1枚目かどうかの判定もしています。
- 70~77行目…印刷最終ページの処理です。最終レコードを差し込んだ際、差し込み件数<差し込み件数指定値の場合（印刷が1枚で終了かつ60~68行目が1回も成立しない場合）と、差し込み件数指定値で除して余りがある場合（差し込み件数が最終ページで端数になる場合）の処理です。除して余りが無い場合は60~68行目が成立するので最終ページ処理は不要になります。
全部で8パターンのコードを紹介しました。最後に紹介したコードは、少し改変すればラベル発行などにも応用できると思います。是非試してみて下さい。