83本目：請求書を作成してPDF出力

Excel&VBA解説サイト「エクセルの神髄」様出題の問題集、
「VBA100本ノック」に対する私の回答と解説のページです。

100本ノックの出題リストはこちらから
excel-ubara.com

出題：請求書を作成してPDF出力

#VBA100本ノック 83本目
「売上」シートにある全取引先のPDF請求書を作成してください。
Thisworkbookパスの下に「請求書」フォルダを作成し、ファイル名「取引先名_yyyymm.pdf」で出力。yyyymmは実行日。
※商品行は10行を超えません。
※取引先名はファイルに使えない文字は使っていません。

◇ 出題ページはこちら

ソースコード

定義モジュール

Option Explicit

' 売上
Public Const R1st売上 = 2
Public Const C1st売上 = 1
Public Enum CNo売上
    取引先CD = C1st売上
    取引先名
    商品名
    数量
    税抜単価
    税抜金額
End Enum
Public Const CLast売上 = CNo売上.税抜金額

' 取引先マスタ
Public Const R1st取引先マスタ = 2
Public Const C1st取引先マスタ = 1
Public Enum CNo取引先マスタ
    取引先CD = C1st取引先マスタ
    取引先名
    郵便番号
    住所1
    住所2
End Enum
Public Const CLast取引先マスタ = CNo取引先マスタ.住所2

' 請求書
Public Const Adrs請求書_クリアエリア = "A2:A5,A10:D24"
Public Const Adrs請求書_取引先名 = "A2"
Public Const Adrs請求書_郵便番号 = "A3"
Public Const Adrs請求書_住所1 = "A4"
Public Const Adrs請求書_住所2 = "A5"
Public Const R1st請求書 = 10
Public Const C1st請求書 = 1
Public Enum CNo請求書
    品名 = C1st請求書
    [_空行1]
    数量
    単価
    金額
    摘要
End Enum
Public Const CLast請求書 = CNo請求書.摘要

メインモジュール

Option Explicit

' 100本ノック083：請求書を作成してPDF出力
Sub 全取引先の請求書を作成してPDFファイルに出力する()
    
    ' 出力先フォルダを取得(なければ作成）
    Dim Path出力フォルダ As String: Path出力フォルダ = ThisWorkbook.Path & "\請求書"
    If Dir(Path出力フォルダ, vbDirectory) = "" Then MkDir (Path出力フォルダ)
    
    ' 売上シート全行をループ
    Dim R As Long, R1st出力 As Long, RLast出力 As Long
    R1st出力 = R1st売上
    For R = R1st売上 To Get最終行(WS売上)

        ' 取引先CDが変わる最後の行で出力処理
        If WS売上.Cells(R, CNo売上.取引先CD) <> _
           WS売上.Cells(R + 1, CNo売上.取引先CD) Then

            RLast出力 = R

            ' 取引先ごとの転記処理
            Call 売上シート→請求書(R1st出力, RLast出力)

            ' PDFファイルに出力
            Call シートをPDFに出力する(WS請求書, Path出力フォルダ _
                , WS請求書.Range(Adrs請求書_取引先名) & "_" & Format(Date, "yyyymm") & ".pdf")
            
            ' 出力行記憶変数の更新
            R1st出力 = R + 1
            RLast出力 = 0
        End If

    Next

End Sub

' 取引先ごとの転記処理
Private Sub 売上シート→請求書(R1st出力 As Long, RLast出力 As Long)
    
    ' 請求書をクリア
    WS請求書.Range(Adrs請求書_クリアエリア).Value = ""
    
    ' マスタを検索
    Dim R_マスタ As Long
    R_マスタ = Match行番号(WS売上.Cells(R1st出力, CNo売上.取引先CD) _
                                  , WS取引先マスタ.Columns(CNo取引先マスタ.取引先CD))
    
    ' マスタの情報を出力
    If R_マスタ > 0 Then
        WS請求書.Range(Adrs請求書_取引先名) = WS取引先マスタ.Cells(R_マスタ, CNo取引先マスタ.取引先名)
        WS請求書.Range(Adrs請求書_郵便番号) = WS取引先マスタ.Cells(R_マスタ, CNo取引先マスタ.郵便番号)
        WS請求書.Range(Adrs請求書_住所1) = WS取引先マスタ.Cells(R_マスタ, CNo取引先マスタ.住所1)
        WS請求書.Range(Adrs請求書_住所2) = WS取引先マスタ.Cells(R_マスタ, CNo取引先マスタ.住所2)
    End If
    
    ' データを出力
    Dim 出力データ数 As Long: 出力データ数 = RLast出力 - R1st出力 + 1
    Call 値をコピーする(WS売上.Cells(R1st出力, CNo売上.商品名) _
                         , WS請求書.Cells(R1st請求書, CNo請求書.品名), 出力データ数, 1)
    Call 値をコピーする(WS売上.Cells(R1st出力, CNo売上.数量) _
                         , WS請求書.Cells(R1st請求書, CNo請求書.数量), 出力データ数, 1)
    Call 値をコピーする(WS売上.Cells(R1st出力, CNo売上.税抜単価) _
                         , WS請求書.Cells(R1st請求書, CNo請求書.単価), 出力データ数, 1)

End Sub

汎用関数モジュール

Option Explicit

' WorksheetFunctionの短縮取得
' 参考：https://www.limecode.jp/entry/utility/shortcall-worksheetfunction
Function Fx() As WorksheetFunction
    Set Fx = WorksheetFunction
End Function

' 最終行の取得
' 参考：https://www.limecode.jp/entry/library/get-lastrow-lastcolumn
Function Get最終行(指定オブジェクト As Variant, Optional ByVal C As Long = -1) As Long

    ' 渡されたオブジェクトからセル範囲を取得
    Dim 対象セル範囲 As Range
    Select Case TypeName(指定オブジェクト)
    Case "Range"
        If 指定オブジェクト.Cells.CountLarge = 1 Then ' 単独セルにはCurrentRegionを取る
            Set 対象セル範囲 = 指定オブジェクト.CurrentRegion
        Else
            Set 対象セル範囲 = 指定オブジェクト
        End If
    Case "Worksheet"
        Set 対象セル範囲 = 指定オブジェクト.UsedRange
    Case "AutoFilter", "ListObject"
        Set 対象セル範囲 = 指定オブジェクト.Range
    Case Else
        Err.Raise 1000, , "対象外のオブジェクト「" & TypeName(指定オブジェクト) & "」が指定されました。"
    End Select

    ' エリアの最終行を取得
    Get最終行 = 対象セル範囲.Rows.Count + 対象セル範囲.Row - 1

    ' 列が指定されていればその列の入力最終行を取得
    If C <> -1 Then
        Do While 対象セル範囲.Worksheet.Cells(Get最終行, C) = ""
            Get最終行 = Get最終行 - 1
            If Get最終行 < 対象セル範囲.Row Then
                Get最終行 = 0
                Exit Function
            End If
        Loop
    End If

End Function

' 行番号の検索
' ◆ ブログ未掲載
Function Match行番号(ByVal 検索値 As Variant, 検索エリア As Range) As Long
    On Error Resume Next
    If IsDate(検索値) Then
        Dim x: x = CDbl(検索値)
        If Err.Number = 0 Then
            Match行番号 = Fx.Match(CDbl(検索値), 検索エリア, 0) + 検索エリア.Row - 1
            Exit Function
        End If
    End If

    Match行番号 = Fx.Match(検索値, 検索エリア, 0) + 検索エリア.Row - 1

End Function

' 値のコピー
' 参考：https://www.limecode.jp/entry/syntax/rangecopy-pastevalues
Sub 値をコピーする(コピー元基準セルまたはエリア As Range, ペースト基準セル As Range _
    , Optional ByVal エリア高 As Long = -1, Optional ByVal エリア幅 As Long = -1)
    
    ' ◇ エリアサイズの省略時は、コピーエリアのサイズを取得
    If エリア高 = -1 Then エリア高 = コピー元基準セルまたはエリア.Rows.Count
    If エリア幅 = -1 Then エリア幅 = コピー元基準セルまたはエリア.Columns.Count
    
    ' 値をコピー
    ペースト基準セル.Resize(エリア高, エリア幅).Value = コピー元基準セルまたはエリア.Resize(エリア高, エリア幅).Value

End Sub

' PDFの出力
' ◆ ブログ未掲載
Sub シートをPDFに出力する(対象シート As Worksheet, Path出力フォルダ As String, ByVal 出力ファイル名 As String)
    対象シート.ExportAsFixedFormat xlTypePDF, Path出力フォルダ & "\" & 出力ファイル名
End Sub

解説

転記マクロの教科書のような問題ですね。

この手のマクロは

• 元データシートのループ部分
• データから帳票への転記部分

を別プロシージャに分けるととても読みやすくなります。

プロシージャ分割の参考にしてみてください。

あとは「各シートレイアウトの定数化」の教科書問題でもありました。

列挙型定数で列番号を、セルアドレスは文字列定数として定義してありますので、
シートレイアウトの変更は「定義モジュール」の変更だけで済むようになっています。

このあたりを「Cells(R, 8)」や「Range("A3")」とやっていると、
行列の挿入時に大変なことになります。

定数化をやったことがない方はこの機会に取り組んでみてください。

詳しくはこちらの記事をどうぞ
www.limecode.jp