74本目：1シート複数表をDB形式に変換

出題：1シート複数表をDB形式に変換

#VBA100本ノック 74本目
「売上」シートには、A列B列に取引先コードと名称があり、その下に見出し行から始まるデータがあります。
「DB」シートにデータベース形式で出力してください。
見出し行は文字列も含め統一されています。
取引先ごとの行数は不定です。
※「DB」は既存で見出しも書式も設定済

◇ 出題ページはこちら

ソースコード

Option Explicit

' 売上シート
Public Enum CNo売上シート
    取引先CD = 1
    取引先名
    商品CD = 1
    商品名
    年月1st
End Enum

' DBシート
Public Const R1stDBシート = 2
Public Enum CNoDBシート
    取引先CD = 1
    取引先名
    商品CD
    商品名
    年月
    金額
End Enum

Option Explicit

' 100本ノック074：1シート複数表をDB形式に変換
Sub 売上シートをテーブル形式に変換してDBシートに出力する()

    ' DBシートのクリア
    Call 指定行より下をすべて削除する(WSDB, R1stDBシート)
    
    ' 売上シートの全行をループ
    Dim R_DB As Long: R_DB = R1stDBシート
    Dim R_売上 As Long
    For R_売上 = 1 To Get最終行(WS売上)
        
        Dim R_現在の見出し As Long
        Dim 現在の取引先CD As String, 現在の取引先名 As String
        
        ' 行ごとの商品CDと商品名を取得
        Dim 現在の商品CD As String: 現在の商品CD = WS売上.Cells(R_売上, CNo売上シート.商品CD)
        Dim 現在の商品名 As String: 現在の商品名 = WS売上.Cells(R_売上, CNo売上シート.商品名)
        
        ' 見出しを検知したら見出し行番号と取引先を更新
        If 現在の商品CD = "商品CD" And 現在の商品名 = "商品名" Then
            R_現在の見出し = R_売上
            現在の取引先CD = WS売上.Cells(R_売上 - 1, CNo売上シート.取引先CD)
            現在の取引先名 = WS売上.Cells(R_売上 - 1, CNo売上シート.取引先名)
        
        ' 各データへの処理
        ElseIf 現在の商品CD <> "" And WS売上.Cells(R_売上, CNo売上シート.年月1st) <> "" Then
            
            ' 各データのすべての列をループ
            Dim C_売上 As Long
            For C_売上 = CNo売上シート.年月1st To Get最終列(WS売上)
                
                ' 見出しが日付形式の列だけを処理
                Dim 現在の年月
                現在の年月 = WS売上.Cells(R_現在の見出し, C_売上)
                If IsDate(現在の年月) Then
            
                    ' DBシートへの転記処理
                    WSDB.Cells(R_DB, CNoDBシート.取引先CD) = 現在の取引先CD
                    WSDB.Cells(R_DB, CNoDBシート.取引先名) = 現在の取引先名
                    WSDB.Cells(R_DB, CNoDBシート.商品CD) = 現在の商品CD
                    WSDB.Cells(R_DB, CNoDBシート.商品名) = 現在の商品名
                    WSDB.Cells(R_DB, CNoDBシート.年月) = 現在の年月
                    WSDB.Cells(R_DB, CNoDBシート.金額) = WS売上.Cells(R_売上, C_売上)
                    R_DB = R_DB + 1
                
                End If
                
            Next  ' データのすべての列をループ’
            
        End If
            
    Next ' 売上シートの全行をループ

End Sub

Option Explicit

' 指定行より下の削除
' 参考：https://www.limecode.jp/entry/utility/delete-rows-below-to-last
Sub 指定行より下をすべて削除する(対象シート As Worksheet, 指定行 As Long)
    With 対象シート
    
        Call フィルターをクリアする(対象シート)
        
        .Range(.Rows(指定行), .Rows(.Rows.Count)).Delete
        
    End With
End Sub

' フィルターのクリア
' ◆ ブログ未掲載
Sub フィルターをクリアする(対象シート As Worksheet)
    If 対象シート.AutoFilterMode = True Then
        If 対象シート.AutoFilter.FilterMode = True Then
            対象シート.AutoFilter.ShowAllData
        End If
    End If
End Sub

' 最終行の取得
' 参考：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

' 最終列の取得
' 参考：https://www.limecode.jp/entry/library/get-lastrow-lastcolumn
Function Get最終列(指定オブジェクト As Variant, Optional ByVal R 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最終列 = 対象セル範囲.Columns.Count + 対象セル範囲.Column - 1

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

End Function

解説

マトリクス形式の表をデータベース形式に変換する、
いわゆる「アンピボット」と呼ばれている処理を行う問題です。

さらに今回は「マトリクス表」が複数あるため、

• 今どのブロック(＝取引先)を扱っているか
• 今どの行(＝商品)を扱っているか
• 今どの列(＝年月)を扱っているか
• 年月を取得する先＝今のブロックの見出し行の位置

を変数として記憶するループ処理を書かなければいけません。

このあたりは「現在の」などの変数名にして、
読んでわかるコードになるように心がけましょう。

入力時のインテリセンスを効かすために英字を使いたい場合は、
Currentを意味する「cur」を接頭するのもおすすめです。

Dim curR_見出し As Long
Dim cur取引先CD As String, cur取引先名 As String

Dim cur商品CD As String: cur商品CD = WS売上.Cells(R_売上, CNo売上シート.商品CD)
Dim cur商品名 As String: cur商品名 = WS売上.Cells(R_売上, CNo売上シート.商品名)

中身自体は愚直にデータを転記するコードになっていますので、
コードの処理に関しては特に追記はありません。

続いてデータに不備があった場合の挙動に関する懸案事項ですが、
取引先の取得に失敗した際の挙動に注意する必要があると思います。

こういったデータはどの程度同じ形になってくれているかわかりませんからね。

もし

こんな風に取引先が消えていたり、
レイアウトが変わったせいで取引先行として検知できなかったとき、
前の取引先のデータとして取り込まれると困ります。

せめて「空の取引先」のデータとしてDBに出力されるよう、
見出し行を検知したところでその上の行から取引先を取得してみました。

まあこのあたりは気配りが逆に裏目になってしまうこともありますし、
どんなに気を付けても100%ユーザーの入力不備に対応することは不可能です。

色で判定したらしたで、商品にも同じ色を付けられたりとかね(´∀｀;)

しっかり入力ルールを決めたり成果物をチェックする工程を設けたり、
このあたりはケースバイケースで運用でカバーしていきましょう。