Excel VBA

Excel VBAで別シートへの値挿入とPDF保存を自動化するマクロ

この前こちらでExcel VBAを使ってPDF保存するマクロをメモしました。今回はこのマクロを使ったちょっとした応用バージョンのマクロをメモします。

このマクロでできること

まずはじめに、ここに載せるマクロで何ができるかを簡単に書いておきます。このマクロは、お客さんに渡す領収書のような書類をPDF化したものを自動作成、保存することを目的としたマクロです。以下で例を用いて説明します。
以下のようにお客さんの情報としてDate(領収日)、Name(名前)、Amount(金額)が書かれた「Database」という名前のシートと、「Receipt」という領収書のテンプレートとなるシートがあります。

database図1 お客さんの情報が格納されているシート「Database」


receipt_temp図2 領収書のテンプレートであるシート「Receipt」


そして以降に載せるマクロでは、Databaseシートにおいて、以下のように名前を選択した各お客さんの情報(Date, Name, Amount)をテンプレートであるReceiptシートの対応する部分に自動で挿入し(DatabaseシートのData,Name,AmountをReceiptシートのData,Name,Amount横の空欄に挿入)、挿入後にReceiptシートをPDF化して保存することができます。

selected2図3 DatabaseシートのNameを選択した状態


例えば、図3のように、「Mick」、「Smith」、「Lynda」、「Liz」が選択された状態の場合、MickのData、Name、Amountが以下のようにReceiptシートに挿入され、これがPDFとして指定したフォルダに保存されます。

mick


そして同様に選択されたSmithには以下のようにReceiptシートが作成され、これがPDFで保存されます。

receipt_image


残りの「Lynda」、「Liz」についても同様です。なお、お客さんの名前の選択範囲は図3のように連続していても、していなくても大丈夫です。これが以降に載せるマクロができることです。このマクロ自体は実用性はほとんどありませんが、いろんなことの応用にできると思うのでメモとして残しておきます。

環境

  • Office 2010 Excel
  • Windows 7 Ultimate 64bit


準備

準備としては、上記のDatabase、Receiptシートを用意することと、Excelでマクロを使用可能にしておくことぐらいです。何かをインストールとかは不要です。そのままコピペで使用できると思います。

マクロの説明

以下にマクロを載せます。このマクロは、main関数(createReceipt)、Databaseシートの値をReceiptシートに挿入する関数(insertReceipt)、PDF化して保存する関数(printPDF)に分かれています。

Sub createReceipt()
      Dim AreaCount As Integer, NRow As Integer, NColumn As Integer
      Dim NRowLast As Integer, NColumnLast As Integer
      Dim num As Integer
     
      Dim List() As Integer '選択中のセルの行番号を保存する配列
      Dim myList As String '選択中のNameを保存する変数

      Dim rowCount As Integer '選択中のセル数を保存する変数
      Dim i, j, k As Integer 'for文用

      Dim rowNum As Integer '
      Dim ans As Integer
      Dim printSheet As String 'テンプレートシートのシート名
      
      printSheet = "Receipt" 'Receiptシートの指定

      j = 0
      num = 10 '一度に選択できるセルの最大数
      ReDim List(num)
      
      AreaCount = Selection.Areas.Count 'セルの選択範囲の数
      rowCount = Selection.Count '選択中のセル数
      
      If AreaCount = 0 Then
        MsgBox "Please select Customer name"
        Exit Sub
      End If
     
      '選択中のセルの数が最大数numを超えていたら終了
      If rowCount > num Then
       MsgBox "The number of SelectedCell( " & rowCount & " ) exceeds " & num
       Exit Sub
      End If
      
     For i = 1 To AreaCount
       NRow = Selection.Areas(i).Row
       NRowLast = Selection.Areas(i).Row + Selection.Areas(i).Rows.Count - 1
       rowNum = Selection.Areas(i).Rows.Count - 1
        
        '選択中のセルが空だったら終了    
        If ActiveSheet.Range("B" & Selection.Areas(i).Row).Value = "" Then
          MsgBox "There is no Customer Name"
          Exit Sub
        End If
  
        If NRow = NRowLast Then '選択されているセルが単一である場合の処理
           myList = myList & ActiveSheet.Range("B" & NRow) & vbCrLf '選択されているセル(Name列)の値を文字列として結合
           List(j) = NRow 'Listに選択されていたセルの行番号を保存
           j = j + 1

        Else '選択されているセルが単一ではなく連続している複数の場合の処理
         For k = 0 To rowNum 
           myList = myList & ActiveSheet.Range("B" & NRow + k) & vbCrLf '選択されているセル(Name列)の値を文字列として結合
           List(j) = NRow + k 'Listに選択されていたセルの行番号を保存
           j = j + 1
         Next k
        End If
     Next
        
       ' ダイアログを出して確認
       ans = MsgBox("Create " & printSheet & " for " & vbCrLf & myList & " ?", vbOKCancel, "Confirmation")

       If ans = vbOK Then 'ダイアログでOKを押した場合の処理
       
        For i = 0 To num
         
          If List(i) <> 0 Then
           Call insertReceipt(List(i), printSheet) '下記のinsertReceipt関数を呼び出し
           Call printPDF(printSheet, Range("B" & List(i)).Value) '下記のprintPDF関数を呼び出し。ここでは引数としてNameの値を渡している。
          Else
           Exit For
          End If
        Next i
        MsgBox "Receipt is created"
        
       Else  'ダイアログでCancelを押した場合の処理
          MsgBox "Cancelled"
          Exit Sub
       End If
              
  End Sub


Sub insertReceipt(ByVal rowNum As Integer, ByVal printSheet As String)

    'pdfName = ActiveSheet.Range("T1")
    Sheets(printSheet).Range("C4").Value = ActiveSheet.Range("A" & rowNum) 'Date
    Sheets(printSheet).Range("C6").Value = ActiveSheet.Range("B" & rowNum) 'Name
    Sheets(printSheet).Range("C8").Value = ActiveSheet.Range("C" & rowNum) 'Amount
       
End Sub

  ' printSheetがPDF印刷するシート名、customerNameは作成するPDFのファイル名に使う引数
Sub printPDF(ByVal printSheet As String, ByVal customerName As String)
     '下記参照
End Sub


createReceipt関数

ここでは、選択されたセルの行番号とその値を取得、保存し、それらをinsertReceipt関数、printPDF関数に渡しています。

36〜59行

ここは複数の選択範囲から選択されているセルの値とその行番号を取得しています。この部分については、以下のサイトのコードを参考にさせて頂きました。ありがとうございました。

複数選択範囲のアドレスを取得する方法 | Microsoftサポート


insertReceipt関数

この関数は引数としてもらった行番号(rowNum)のA列、B列、C列の値をそれぞれ、同じく引数としてもらったシート(printSheet)のセルC4、C6、C8に挿入しています。図2を見るとわかるとおり、C4はDate、C6はName、C8はAmountを挿入するセルです。なお、値の挿入先となるC4、C6、C8にあらかじめ中央寄せやフォントの種類、フォントサイズなどスタイルを指定しておくと、挿入後も自動的にそのスタイルが適用されます。また、図2のように結合セルに値を挿入する場合は、先頭のセルを指定すれば値が挿入されるようです。

printPDF関数

この関数については、こちらに全く同じ関数をメモしてあるもので参照して頂ければと思います。
ただし、3点注意点があります。1点目はprintPDF関数のPDF化する範囲は、今回PDF化するReceiptシートの範囲に合わせてください。
具体的には、以前載せたマクロでは、印刷範囲の指定として、以下のようにA1:E41を指定していますが、

 .PrintArea = "A$1:$E$41" '印刷範囲の指定


今回のReceiptシートでは広すぎるので、例えばA1:H10ぐらいに合わせたほうがいいです。まあ上記のReceiptシートをそのまま使うことは実用上ないと思いますが念の為。

 .PrintArea = "A$1:$H$10" '印刷範囲の指定


また、2点目としては、PDFファイルの保存先となるフォルダをあらかじめ作るのを忘れないようにしてください。PDFファイルの保存先となるフォルダは以下の記述で指定しています。

ChDir "C:\ExcelPDF\" 'カレントフォルダの指定。ここで指定したフォルダにPDFが保存されます。


最後3点目ですが、printPDFでPDF化するシートに画像を挿入してももちろんPDF化できますが、PDF化したシートに画像を挿入したあとで、そのシート上で画像のサイズを変更しないほうがいいです。PDF化するシート上で画像のサイズを変更すると、PDF化した時に画像のサイズがおかしくなります。なので、画像を挿入したい場合は、あらかじめ目的のサイズにしてから挿入したほうがいいです。

まとめ

ここに載せたマクロそのままでは実用的ではないですが、ここからいろいろ応用して手を加えていけば便利なマクロが組めると思います。もしもっと良い方法や使い方などがありましたら教えて頂ければと思います。

SPONSORED LINK

2 thoughts on “Excel VBAで別シートへの値挿入とPDF保存を自動化するマクロ

コメントを残す

メールアドレスが公開されることはありません。