Excel VBAで差し込み印刷を実現する

ExcelとVBAを使った差し込み印刷のやり方 その２です。

こちらの記事では、差し込む先のテンプレートはシート内に１つだけでした。

Wordの差し込み印刷と同じような感覚で使えるようにするためには、１つのテンプレートに複数のレコードを差し込める必要があります。

きっと差し込み印刷というとこっちを想像する方が多かったのかも・・・と上述の記事を書いた後に思った次第です。

ということで、今度は「ExcelとVBAを使ったちゃんとした差し込み印刷」を書いたので晒しておきます。

環境

Excel 2019 64bit

仕様

差込先のテンプレート

順番に見ていきます。

まず、差し込み先となるテンプレートとして、次のようなシートを準備しました。

実際にご自身でお使いになる場合には、差し込み先のテンプレートを、ご自身の実現したいものに置き換えてください。

差し込む場所を特定するためには、差し込みデータの項目名を「<<」と「>>」で挟んで記入しておくことにします。

「<<」と「>>」を使っていることに深い意味はありません。

便宜的に項目名をエスケープする目的のため、この記号はカスタマイズしてもらって大丈夫です。

ただし、差し込みのテンプレートに干渉する可能性のある記号（例えば単純なカッコなど）は避けた方が、予期せぬ挙動を防ぐことができるでしょう。

また、ここではコーディングを単純化するため、項目名(<<>>で囲った差込先)は１セルに１つだけとします。

複数の項目名を横並びにしたいときは、セルに分けてそれぞれ独立した項目として定義する必要がありあります。

差し込み先テンプレートのシート名は「template」とします。

差込元のデータ

差し込むデータは「data」というシート名で同じブックに準備します。

見てもらえればわかりますが、1行目が項目名で、2行目以降が実際のデータになります。

注意点

差し込みデータが多い場合、Excelの行数と列数に注意してください。

差し込み先のテンプレートは１つのテンプレートが複数行、桁になるので、差し込み元のデータが多く、差し込み先テンプレートをたくさん作る場合はテンプレートがExcelの最大行、桁を超えないように注意してください。

Excel 2007以降なら1,048,576行、16384桁が最大です。

まぁ、そこまで大きなデータを差し込むことはあまりないと思いますが・・・。

コード

 

Sub insertSample()
    Const TEMPLATE As String = "template"
    Const DATA     As String = "data"
    
    Const STR_RNG As String = "A1:D7"
    
    Application.ScreenUpdating = False
    
    Dim shTemplate As Worksheet: Set shTemplate = Worksheets(TEMPLATE)
    Dim shData As Worksheet: Set shData = Worksheets(DATA)
    Dim rngObj As Range
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("差し込み先").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    '列番号を取得
    Dim collData As Collection: Set collData = New Collection
    Dim lastCol As Long: lastCol = shData.Cells(1, Columns.Count).End(xlToLeft).Column
    Dim i As Long
    For i = 1 To lastCol
        On Error Resume Next
        collData.Add Item:=i, Key:=shData.Cells(1, i).Value
        On Error GoTo 0
    Next i
    
    'データを差し込む
    Dim lngTargetRow As Long
    Dim strKey As String
    Dim lngLastRow As Long: lngLastRow = shData.Cells(Rows.Count, 1).End(xlUp).Row
    
    '新しい差し込み用シートを用意する
    Dim shNew As Worksheet
    shTemplate.Copy after:=Worksheets(DATA)
    Set shNew = ActiveSheet
    shNew.Name = "差し込み先"
    
    Dim rngNewSh As Range
    Set rngNewSh = shNew.Range(STR_RNG)
    
    Dim lngOffset As Long: lngOffset = Range(STR_RNG).Rows.Count
    
    For lngTargetRow = 2 To lngLastRow
        
        For Each rngObj In rngNewSh
            '差し込み先かどうか判定
            If rngObj.Value Like "<<*>>" Then
                strKey = Replace(Replace(rngObj.Value, "<<", ""), ">>", "")
                rngObj.Value = shData.Cells(lngTargetRow, collData(strKey))
            End If
        Next rngObj
        
        '差し込み先シートの値が入っているセル範囲を取得する
        Set rngNewSh = rngNewSh.Offset(lngOffset).Range(STR_RNG)
        
    Next lngTargetRow
    
    Application.ScreenUpdating = True
    
End Sub

コードの解説

Const TEMPLATE As String = "template"
 Const DATAAs String = "data"

シート名を定数にしておきます。

シート名は環境に合わせて変更してください。

 ConstSTR_RNG as String = "A1:D7"

ここがこのコードのキモになります。

１つのテンプレートの範囲を文字列で指定します。

例えば今回の例では、1つのテンプレートが下記の範囲なのでA1:D7を指定しています。

Application.ScreenUpdating = False

セルへのデータ転記が多くなるので、画面更新を停止しておきます。

Dim shTemplate As Worksheet: Set shTemplate = Worksheets(TEMPLATE)
Dim shData As Worksheet: Set shData = Worksheets(DATA)
Dim rngObj As Range

各変数の準備、ワークシートを変数に割り当てます。

On Error Resume Next
Application.DisplayAlerts = False
Worksheets("差し込み先").Delete
Application.DisplayAlerts = True
On Error GoTo 0

差し込んだ結果となるワークシートを用意します。

「On Error Resume Next」はエラーを無視します。

「On Error GoTo 0」はエラー処理を既定のエラー処理に戻します。

「Application.DisplayAlerts = False」で警告の表示を抑制します。

これをFalseにしておかないと、このような警告が出ます。

'列番号を取得
Dim collData As Collection: Set collData = New Collection
Dim lastCol As Long: lastCol = shData.Cells(1, Columns.Count).End(xlToLeft).Column
Dim i As Long
For i = 1 To lastCol
   On Error Resume Next
   collData.Add Item:=i, Key:=shData.Cells(1, i).Value
   On Error GoTo 0
Next i

これ以降のコードで、データを扱う際に楽をするために、データの項目名と列数をマッピングしておきます。

この手法について詳しくはこちらの記事をご参照ください。

Excel VBAで表の列名とセルの列番号のスマートなマッピング方法 - 適材適所

'データを差し込む
Dim lngTargetRow As Long
Dim strKey As String
Dim lngLastRow As Long: lngLastRow = shData.Cells(Rows.Count, 1).End(xlUp).Row
'新しい差し込み用シートを用意する
Dim shNew As Worksheet
shTemplate.Copy after:=Worksheets(DATA)
Set shNew = ActiveSheet
shNew.Name = "差し込み先"

変数とシートを準備します。

Dim rngNewSh As Range
Set rngNewSh = shNew.Range(STR_RNG)

１つのテンプレートの範囲を変数に格納しておきます。

Dim lngOffset As Long: lngOffset = Range(STR_RNG).Rows.Count

先ほどのrngNewSh変数の起点となるセルを移動させるための移動量を求めています。

うまく表現できているかどうか・・・。

わかりづらい部分ですので、実際にコードを実行いただき、挙動を確認して頂くのがよいかと思います。

For lngTargetRow = 2 To lngLastRow
      For Each rngObj In rngNewSh
      '差し込み先かどうか判定
      If rngObj.Value Like "<<*>>" Then
         strKey = Replace(Replace(rngObj.Value, "<<", ""), ">>", "")
         rngObj.Value = shData.Cells(lngTargetRow, collData(strKey))
      End If
   Next rngObj
   '差し込み先シートの値が入っているセル範囲を取得する
   Set rngNewSh = rngNewSh.Offset(lngOffset).Range(STR_RNG)
Next lngTargetRow

ここは、前回の差し込み印刷の方法と同じです。

１つだけ異なるのは、

テンプレートの範囲を繰り返しごとに移動させている点です。

Set rngNewSh = rngNewSh.Offset(lngOffset).Range(STR_RNG)

ここがこのコードのキモ２です。

OffsetプロパティはRange型を返します。

Range型には、Rangeプロパティがあります。

このRangeプロパティ、何かというと、

そのセルを起点としたRange(範囲)を示しています。

ここでは、rngNewSh.Offset(lngOffset)のセルを起点として、STR_RNGの範囲です。

イメージとしては、繰り返し毎にセル範囲が移動していくような感じです・・・。

と説明してみましたが、ここも中々文章では意味が通じづらいかと思います

やはり実際にコードを実行頂き、変数の中身など挙動を見てもらうのが良いかと思います。

あとは、これがデータシートのレコードの数だけ実行されていきます。

Application.ScreenUpdating = True

最後に画面の停止を解除して終了です。

差し込み印刷とか書いてますが、印刷まではしてません。

印刷してしまうと、場合によっては大量の用紙が出力されてしまう恐れがあるためです。

終わりに

差し込み印刷をExcelとVBAで実現することができました。

え？ここまでやるならWordを使った方が早い？？

あーあー、聞こえない聞こえない！！

だって作表はやっぱりWordよりExcelの方が楽なんですもの。

しかもWordを挟むとか面倒じゃないですか・・・。

やっぱりExcelオールインワンで実現したいですよね？ね？

ということでExcelとVBAで差し込み印刷をやってみました。

ここまでお読みいだだき、ありがとうございました。