25本目：マトリックス表をDB形式に変換

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

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

出題：マトリックス表をDB形式に変換

#VBA100本ノック 25本目
画像1のように「売上」シートに横に日付と金額が入力されています。
行数・列数(日数)は増減します。
A列はセル結合されています。
画像2のようにデータベース形式に変換して「売上DB」シートに出力してください。
※「売上DB」は既存で見出しも入っています。

◇ 出題ページはこちら

ソースコード

定義モジュール

Option Explicit

' 売上
Public Const RNo売上_見出し = 1
Public Const R1st売上 = 2
Public Const C1st売上 = 1
Public Enum CNo売上
    部門 = C1st売上
    区分
    日付1st
End Enum

' 売上DB
Public Const R1st売上DB = 2
Public Const C1st売上DB = 1
Public Enum CNo売上DB
    部門 = C1st売上DB
    区分
    日付
    金額
End Enum
Public Const CLast売上DB = CNo売上DB.金額

メインモジュール

Option Explicit

' 100本ノック025：マトリックス表をDB形式に変換
Sub 売上シートをDB形式に変換する()

    Call 指定行より下をすべて削除する(WS売上DB, R1st売上)
    
    ' 売上表の全行をループ
    Dim R_売上DB As Long: R_売上DB = R1st売上DB
    Dim R_売上 As Long
    For R_売上 = R1st売上 To Get最終行(WS売上)
    
        ' 結合先頭セルごとに部門を更新
        Dim 現在の部門 As String
        If Is結合先頭セル(WS売上.Cells(R_売上, CNo売上DB.部門)) Then
            現在の部門 = WS売上.Cells(R_売上, CNo売上DB.部門)
        End If
        
        ' 今の行の区分を取得
        Dim 現在の区分 As String
        現在の区分 = WS売上.Cells(R_売上, CNo売上.区分)
        
        ' 日付ごとのデータをDBに書き出し
        Dim C_売上 As Long
        For C_売上 = CNo売上.日付1st To Get最終列(WS売上)
        
            WS売上DB.Cells(R_売上DB, CNo売上DB.部門) = 現在の部門
            WS売上DB.Cells(R_売上DB, CNo売上DB.区分) = 現在の区分
            WS売上DB.Cells(R_売上DB, CNo売上DB.日付) = WS売上.Cells(RNo売上_見出し, C_売上)
            WS売上DB.Cells(R_売上DB, CNo売上DB.金額) = WS売上.Cells(R_売上, C_売上)
            R_売上DB = R_売上DB + 1
            
        Next
        
    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

' 結合セル判定
' 参考：https://www.limecode.jp/entry/syntax/check-mergecells-mergearea
Function Is結合先頭セル(判定セル As Range) As Boolean
    Is結合先頭セル = (判定セル.MergeCells And 判定セル.Address = 判定セル.MergeArea.Cells(1, 1).Address)
End Function
Function Is結合内部セル(判定セル As Range) As Boolean
    Is結合内部セル = (判定セル.MergeCells And 判定セル.Address <> 判定セル.MergeArea.Cells(1, 1).Address)
End Function
Function Is結合セル全体(判定エリア As Range) As Boolean
    Is結合セル全体 = (判定エリア.MergeCells And 判定エリア.Address = 判定エリア.Cells(1, 1).MergeArea.Address)
End Function

解説

マトリクス形式の表をデータベース(テーブル)形式に変換する問題でした。

いわゆる「アンピボット」と呼ばれる処理ですね。

処理自体は単純で、行ループ→列ループの2重ループですべてのデータ書き出していくだけです。

行のループ時に「部門」「区分」を取得・記憶しておき、
列のループ時にその内容を書き出すロジックになっています。

特に細くはありませんが、「部門に空のセルがある」データだった場合に、
「部門列が空でなければ更新」というコードを書いていると不具合になります。

If 部門セル <> "" Then ' ← 部門が空のデータがあると前の部門のデータとして書き出してしまう。

If Is結合先頭セル(部門セル) Then ' ← 多少安全

　
といっても「多少」と称した通り、
こっちはこっちで結合が解けているとエラーになりますけどね(´∀｀;)

結合の先頭セルかを判定するコードは関数にしておくと便利ですので、
よく扱う方はお持ち帰りください。