差込印刷マクロ例

'印刷シート作成マクロ

'このマクロは標準モジュールに作成してください。
'実際に利用するときは、以下の前提を守ってください。

'印刷用シートには印刷範囲を設定する。印刷範囲は必ず1行目から始まる。
'印刷用シートの、データを転記するセルには名前を付けておく。
'住所データは1行目は見出し行、2行目からデータ行とする。
'住所データは1件1行とし、各行のA列には必ずデータがある。

'下の"初期設定"と"転記"プロシージャを必要に応じて書き換え、
'"印刷シート作成"を実行してください。

Sub 印刷シート作成()
    Dim 印刷シート     As Worksheet
    Dim データシート   As Worksheet
    Dim ページ行数     As Long
    Dim ページ開始位置 As Long
    Dim データ行       As Long

    '画面更新を停止
    Application.ScreenUpdating = False

    'シートの初期設定
    初期設定 印刷シート, データシート

    '印刷用シートのコピーを作成
    印刷シート.Copy

    '印刷用シートの1ページの行数を取得
    ページ行数 = Range("Print_Area").Rows.Count

    '転記先の行位置の初期化（ページ開始位置はページの先頭行-1とする）
    ページ開始位置 = 0

    'データシートの2行目から最終行まで繰り返す
    For データ行 = 2 To データシート.Cells(データシート.Rows.Count, 1).End(xlUp).Row

        '印刷範囲を新しいページにコピー
        Range("Print_Area").Copy Range("Print_Area").Offset(ページ開始位置)

        'ページの1行目に改ページを挿入
        If ページ開始位置 > 0 Then
            Range("Print_Area").Offset(ページ開始位置).Rows(1).PageBreak = xlManual
        End If

        'データを転記
        転記 ページ開始位置, データシート.Cells, データ行

        '次のページを処理するためにページ開始位置を更新
        ページ開始位置 = ページ開始位置 + ページ行数
    Next

    '印刷範囲を再設定
    ActiveSheet.PageSetup.PrintArea = Range("Print_Area").Resize(ページ開始位置).Address

    '画面更新を再開
    Application.ScreenUpdating = True
End Sub


'初期設定プロシージャ
'実際のブック名、シート名に書き換えてください。

Private Sub 初期設定(印刷シート As Worksheet, データシート As Worksheet)

    '印刷シートに"顧客住所録（練習用）.xls"の"宛名印刷"を設定する
    Set 印刷シート = Workbooks("顧客住所録（練習用）.xls").Sheets("宛名印刷")

    'データシートに"顧客住所録（練習用）.xls"の"住所録"を設定する
    Set データシート = Workbooks("顧客住所録（練習用）.xls").Sheets("住所録")

End Sub


'データ転記プロシージャ
'実際のデータに合わせて書き換えてください。

Private Sub 転記(ページ開始位置 As Long, データ範囲 As Range, データ行 As Long)

    '郵便番号のセルにデータシートの3列目（C列）のデータを転記する
    Range("郵便番号").Offset(ページ開始位置).Value = データ範囲(データ行, 3).Value

    '住所のセルにデータシートの4列目（D列）のデータを転記する
    Range("住所").Offset(ページ開始位置).Value = データ範囲(データ行, 4).Value

    '名前のセルにデータシートの2列目（B列）のデータを転記する
    Range("名前").Offset(ページ開始位置).Value = データ範囲(データ行, 2).Value & " 様"

End Sub