ExcelVBAで差し込み印刷もどきをやってみる

Excel業務あるあるシリーズ

どこかの誰かが、どこかで苦戦しているかも知れない、自動化したいけど、なかなかいい考えが浮かばない・・・。

そんなよくありそうな作業の悩みを自動化しようという、このシリーズ。

今回は「差し込み印刷」もどきです。

Excelで差し込み印刷

Wordなら簡単にできる差し込み印刷ですが、Excelで同じことをやろうとすると、これが中々一筋縄ではいきません。

本当はExcelで作った帳票に差し込み印刷的なことをやりたいけど、しょうがないかいからWordでやっている・・・なんて人もいるかも知れませんね（聞いたことないけど）。

今回は、Excelで差し込み印刷もどきをやる、ちょっとしたアイディア（コード）を紹介しようと思います。

想定されるケース

• 差し込みたい帳票はExcelで作成済み。わざわざWordで作り直すのも面倒・・・。
• Wordは動きがよくわからないから使いたくない！というWordはちょっと・・・の人。
• Wordで帳票作るの超面倒。って人

はい、全て私のことです。

では、次に具体的にどんな風にやるのか見てみましょう。

Excelの差し込み印刷の考え方

1. 帳票のひな形を作っておく
2. 帳票のひな形に項目名を埋め込む
3. 埋め込んだ項目名を置換して印刷する
4. データが終わるまで繰り返す

こう書き出してみると、とっても単純ですね。

同様にプログラムも、そこまで手の込んだことは必要ありません。

Excelの構成もシンプルです。

ブックの構成

ひな形とデータの２つを用意します。

ひな形はなんでもいいのですが、こんなのありそう、ということで行政っぽい申請書を準備しました。

ポイントは<<ふりがな>>のような、二重のカッコで囲まれた部分です。

これが埋め込まれた項目名です。

転記するデータは、なんちゃって個人情報を使わせていただこうと思います。

なんちゃって個人情報

名前,ふりがな,アドレス,性別,年齢,誕生日,婚姻,都道府県,携帯,キャリア,カレーの食べ方
哀川 ジョージ,あいかわ じょーじ,aikawa_george@example.com,男,27,1992/2/29,未婚,長野県,080-7431-4514,au,奥ルー・せき止め派
野田 愛子,のだ あいこ,noda_aiko@example.com,女,76,1943/5/23,既婚,新潟県,080-7608-6149,ドコモ,奥ルー・別口派

この個人情報をひな形に埋め込まれた項目名と置換しつつ、差し込みを行おう、ということです。

コードの実装

 

Sub sashikomi_sample()
    Const TEMPLATE As String = "template"
    Const DATA     As String = "data"
    
    Application.ScreenUpdating = False
    
    Dim shTemplate As Worksheet: Set shTemplate = Worksheets(TEMPLATE)
    Dim shData As Worksheet: Set shData = Worksheets(DATA)
    Dim rngObj As Range
    
    '列番号を取得
    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
        collData.Add Item:=i, Key:=shData.Cells(1, i).Value
    Next i
        
    'データを差し込む
    Dim lngTargetRow As Long
    Dim strKey As String
    Dim lngLastRow As Long: lngLastRow = shData.Cells(Rows.Count, 1).End(xlUp).Row
    
    For lngTargetRow = 2 To lngLastRow
        '差し込み先シートを削除する
        On Error Resume Next
        Application.DisplayAlerts = False
        Worksheets("差し込み先").Delete
        Application.DisplayAlerts = True
        On Error GoTo 0
    
        '新しい差し込み用シートを用意する
        Dim shNew As Worksheet
        shTemplate.Copy after:=Worksheets(DATA)
        Set shNew = ActiveSheet
        shNew.Name = "差し込み先"
        
        '差し込み先シートの値が入っているセル範囲を取得する
        Dim rngNewSh As Range: Set rngNewSh = shNew.UsedRange.SpecialCells(xlCellTypeConstants)
        
        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
        '印刷プレビューを出す
        shNew.PrintPreview
    Next lngTargetRow
    
    Application.ScreenUpdating = True
    
End Sub

コードの解説

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

シート名だけ定数を用意しています。なんだか中途半端ですが。

    Application.ScreenUpdating = False

画面の更新を停めます。定石ですね。

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

変数の割り当てや変数の準備をしています。

   '列番号を取得
   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
       collData.Add Item:=i, Key:=shData.Cells(1, i).Value
   Next i

dataシートの列名とセルの列番号をマッピングしています。詳しくはこちらの記事をご参照頂けますと幸いです。

     'データを差し込む
    Dim lngTargetRow As Long
    Dim strKey As String
    Dim lngLastRow As Long: lngLastRow = shData.Cells(Rows.Count, 1).End(xlUp).Row

データを差し込むための準備。各種変数を宣言、割り当てです。

    For lngTargetRow = 2 To lngLastRow

dataシートのレコード分、処理を行います。

        '差し込み先シートを削除する
        On Error Resume Next
        Application.DisplayAlerts = False
        Worksheets("差し込み先").Delete
        Application.DisplayAlerts = True
        On Error GoTo 0

既に「差し込み先」という名前のシート名があるとエラーになるので、削除しておきます。

       '新しい差し込み用シートを用意する
        Dim shNew As Worksheet
        shTemplate.Copy after:=Worksheets(DATA)
        Set shNew = ActiveSheet
        shNew.Name = "差し込み先"

templateシートをコピーし、差し込み先となるシートを新しく用意します。

         '差し込み先シートの値が入っているセル範囲を取得する
        Dim rngNewSh As Range: Set rngNewSh = shNew.UsedRange.SpecialCells(xlCellTypeConstants)

先ほど用意した、差し込み先のシートの中で、値が入っているセル範囲を取得しています。

「.SpecialCells(xlCellTypeConstants)」をつけることで、値が入っているセルだけを取得することができます。

      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

先ほど取得したセル範囲に対して、１セルずつ走査し、値が「<<」と「>>」で囲まれている場合、差し込み項目と判断しています。

今回は<<○○>>としましたが、どんな記号でも大丈夫です。

                rngObj.Value = shData.Cells(lngTargetRow, collData(strKey))

ここで差し込み先シートの値を置換しています。

        '印刷プレビューを出す
        shNew.PrintPreview

差し込み先シートを印刷プレビューします。

実行してみる

今回、例のため、データは２件です。実行しみると・・・。

おお、印刷プレビューが出て・・・

ちゃんと、２件が印刷プレビューされました。

終わりに

Excel VBAによる差し込み印刷もどきを作ってみました。

処理速度など、もっと改善できるコードはありますが、何かの参考になれば。

これで、苦しんでいる人が一人でも救われれば・・・。

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

関連記事

www.tekizai.net