VBAノック42本目：データベース形式に変換

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

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

出題：CSV出力
ソースコード
解説

出題：CSV出力

画像1のように「階層」シートに階層を表したデータがあります。
これを画像2のように「階層DB」シートにデータベース形式に変換して出力してください。

#VBA100本ノック 42本目

データサンプル

◇ 出題ページはこちら

ソースコード

定義モジュール

Option Explicit

' 階層
Public Const R1st階層 = 2
Public Enum CNo階層
    大項目 = 1
    中項目
    小項目
    詳細
End Enum

メインモジュール

Option Explicit

' 100本ノック042：データベース形式に変換
Sub 階層シートを階層DBへ出力する()
    
    WS階層DB.Cells.Delete
    
    WS階層.UsedRange.Rows(1).Copy WS階層DB.Range("A1")
    
    ' データ全行をループ
    Dim R_出力 As Long: R_出力 = R1st階層
    Dim R As Long
    For R = R1st階層 To Get最終行(WS階層)
        
        Dim cur大項目 As String
        Dim cur中項目 As String
        Dim cur小項目 As String
        
        ' 大項目行
        If WS階層.Cells(R, CNo階層.大項目) <> "" Then
            cur大項目 = WS階層.Cells(R, CNo階層.大項目)
            cur中項目 = ""
            cur小項目 = ""
        End If
                
        ' 中項目行
        If WS階層.Cells(R, CNo階層.中項目) <> "" Then
            cur中項目 = WS階層.Cells(R, CNo階層.中項目)
            cur小項目 = ""
        End If
                
        ' 小項目行
        If WS階層.Cells(R, CNo階層.小項目) <> "" Then
            cur小項目 = WS階層.Cells(R, CNo階層.小項目)
        End If
                
        ' 詳細
        If WS階層.Cells(R, CNo階層.詳細) <> "" Then
            WS階層DB.Cells(R_出力, CNo階層.大項目) = cur大項目
            WS階層DB.Cells(R_出力, CNo階層.中項目) = cur中項目
            WS階層DB.Cells(R_出力, CNo階層.小項目) = cur小項目
            WS階層DB.Cells(R_出力, CNo階層.詳細) = WS階層.Cells(R, CNo階層.詳細)
            R_出力 = R_出力 + 1
        End If
    
    Next
    
End Sub

汎用関数モジュール

Option Explicit

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