和風スパゲティのレシピ

日本語でコーディングするExcelVBA

トップ > VBA問題集 > VBA課題005「プラモの部品構成表を作成する」回答コード

VBA課題005「プラモの部品構成表を作成する」回答コード

VBA問題集 分岐・ループ構文 Dictionary VBA

Excel・VBA総合コミュニティ「Excel-Fun.xls*」にて毎月出題される、
VBAの問題に対する私の回答ソースコードを掲載いたします。


今回掲載するコードは第4回課題共有会の課題でもあった、
「プラモの部品構成表を作成する」問題です。
VBA課題005「プラモの部品構成表を作成する」

今回も読みやすさ重視で書いてみましたので、
よろしければご参考ください(´∀｀)

課題の内容

今回は2つのデータをルールに沿って結合し一覧表を作成する課題です。

2つのデータから階層構成データを作成


詳細は下記リンク内にある「課題説明」シートをご確認ください。


せっかくなので回答を見る前に皆さんも挑戦してみましょう。

一度自分が作ってから他の人のコードを見ることで、
学習効果が何倍にも高まります。

完成させなくても、出来る範囲で解くだけでも十分効果がありますので、
是非ともトライしてみてください！

課題共有会とは

ExcelVBAに関する1つのお題にみんなで回答し、
各自のコードを解説しあう勉強会です。


他者のコードを見る機会が少ないVBAユーザーにとって、
いろいろな手法・記法に触れることができる貴重な機会です。

もちろん聞き専での参加もできますので、
ご興味がある方はコミュニティを覗いてみてください。


今回の「プラモの部品構成表を作成する」に対する私以外の回答コードも公開されています。

これだけたくさんの方のソースコードを見れる機会はなかなかないと思いますので、
是非ともVBAの勉強にお役立ていただければと思います。


◇ 「プラモの部品構成表を作成する」の課題ファイルはこちら
Discord：★出題【VBA】#005 プラモの部品構成表を作成する


◇ 「プラモの部品構成表を作成する」への回答集はこちら
Discord：☆回答【VBA】#005 プラモの部品構成表を作成する


※上記はDiscord参加済みの方用のURLです
　未参加の方は下記からご参加ください！
www.limecode.jp

課題の回答ファイル

実際の回答ファイルはこちらをご覧ください。
(和風スパ)【VBA】005_プラモの部品構成表を作成する.xlsm

ソースコード

標準モジュール：Df_シートレイアウト

Option Explicit

' シートレイアウト
' （※1） シート数式はすべてマジックナンバーのため注意

Public Const R1stPN部品リスト = 3
Public Enum CNoPN部品リスト
    C1st = 2
    部品コード = C1st
    名称
    素材
    コスト
    CLast = コスト
End Enum

Public Const R1stPS構成リスト = 3
Public Enum CNoPS構成リスト
    C1st = 7
    親コード = C1st
    子コード
    名称
    数
    CLast = 数
End Enum

Public Const R1stBOM部品構成表 = 3
Public Enum CNoBOM部品構成表
    C1st = 12
    階層レベル = C1st
    部品コード
    名称
    数
    素材
    コスト
    CLast = コスト
End Enum

Public Const Adrs実行パラメータ_トップアセンブリ = "T1"
Public Const Adrs実行パラメータ_数 = "T2"

' 実行シートデータエリア
Function GetRange部品構成表データエリア() As Range
    With WSリスト
        Set GetRange部品構成表データエリア = .Range(.Cells(R1stBOM部品構成表, CNoBOM部品構成表.C1st) _
                                                 , .Cells(GetLastR(WSリスト, CNoBOM部品構成表.部品コード), CNoBOM部品構成表.CLast))
    End With
End Function

' マジックナンバー注意（※1）
Sub シート数式計算部を更新する()
    With WSリスト
    
        Dim Rangeデータエリア As Range
        Set Rangeデータエリア = GetRange部品構成表データエリア

        Dim range計算エリア As Range
        
        Set range計算エリア = Intersect(Rangeデータエリア, .Columns(CNoBOM部品構成表.名称))
        range計算エリア.Formula = "=XLOOKUP(M3,B:B,C:C)"
        range計算エリア.Value = range計算エリア.Value

        Set range計算エリア = Intersect(Rangeデータエリア, .Columns(CNoBOM部品構成表.素材))
        range計算エリア.Formula = "=XLOOKUP(M3,B:B,D:D)"
        range計算エリア.Value = range計算エリア.Value

        Set range計算エリア = Intersect(Rangeデータエリア, .Columns(CNoBOM部品構成表.コスト))
        range計算エリア.Formula = "=XLOOKUP(M3,B:B,E:E)*O3"
        range計算エリア.Value = range計算エリア.Value

    End With
End Sub


' 親コードごとのDictionary[key:子コード,Item:数]
Function GetDic子コードリスト(親コード As String) As Dictionary

    ' 親コード列に対象コードがあるか検索
    Dim R_親コード As Long
    R_親コード = Match行番号(親コード, WSリスト.Columns(CNoPS構成リスト.親コード))
    If R_親コード = 0 Then Exit Function

    Set GetDic子コードリスト = New Dictionary

    ' △ 発見行から次の親コード出現行までループ
    Dim R As Long: R = R_親コード + 1
    Do
        
        ' 子コードを要素に追加
        If WSリスト.Cells(R, CNoPS構成リスト.子コード) <> "" Then
            GetDic子コードリスト.Add WSリスト.Cells(R, CNoPS構成リスト.子コード).Value _
                                   , WSリスト.Cells(R, CNoPS構成リスト.数).Value
        End If
    
        R = R + 1
        If WSリスト.Cells(R, CNoPS構成リスト.親コード) <> "" Then Exit Do
    Loop ' ▽ ' 発見行から次の親コード出現行までループ

End Function
Sub Dictionary生成テスト()
    Call Dictionaryを新規シートに出力する(GetDic子コードリスト("M2-03"))
End Sub

標準モジュール：Pr_BOM部品構成表の出力

Option Explicit

' 実行プロシージャ
Sub ★BOM部品構成表を出力する()

    Call エクセルの自動更新を停止する(False)

    ' 構成表のクリア
    Call ★BOM部品構成表をクリアする
    
    ' 入力不備のチェック
    If Is入力不備を警告する Then Exit Sub
    
    ' パラメータの取得
    Dim Prmトップアセンブリ As String: Prmトップアセンブリ = WSリスト.Range(Adrs実行パラメータ_トップアセンブリ)
    Dim Prm数 As Long: Prm数 = WSリスト.Range(Adrs実行パラメータ_数)
    
    ' ■ メインプロシージャ
    Call 指定コードを部品構成表に出力し子コードに対して再帰呼出する(Prmトップアセンブリ, Prm数, 0)
    
    ' シート数式の更新
    Call シート数式計算部を更新する

    ' 罫線の設定
    GetRange部品構成表データエリア.Borders(xlInsideHorizontal).LineStyle = xlContinuous
    GetRange部品構成表データエリア.Borders(xlEdgeBottom).LineStyle = xlContinuous

    Call エクセルの自動更新を開始する

End Sub

' メインプロシージャ（再帰関数）
Sub 指定コードを部品構成表に出力し子コードに対して再帰呼出する(ByVal 親部品コード As String, ByVal 指定数 As Long, ByVal 呼出階層 As Long)

    Dim R_出力 As Long
    R_出力 = GetLastR(WSリスト, CNoBOM部品構成表.階層レベル) + 1

    ' まずは親コードを出力
    WSリスト.Cells(R_出力, CNoBOM部品構成表.階層レベル) = 呼出階層
    WSリスト.Cells(R_出力, CNoBOM部品構成表.部品コード) = 親部品コード
    WSリスト.Cells(R_出力, CNoBOM部品構成表.部品コード).IndentLevel = 呼出階層
    WSリスト.Cells(R_出力, CNoBOM部品構成表.数) = 指定数
    
    ' 子コードがあれば子コードを出力
    Dim Dic子コードリスト As Dictionary
    Set Dic子コードリスト = GetDic子コードリスト(親部品コード)
    If Not Dic子コードリスト Is Nothing Then
        
        Dim key子コード
        For Each key子コード In Dic子コードリスト.Keys
                        
            ' ■ 再帰呼出
            Call 指定コードを部品構成表に出力し子コードに対して再帰呼出する(key子コード, Dic子コードリスト(key子コード) * 指定数, 呼出階層 + 1)
        
        Next
    
    End If

End Sub

' 部品構成表のクリア
Sub ★BOM部品構成表をクリアする()
    
    With WSリスト
        .Range(.Cells(R1stBOM部品構成表, CNoBOM部品構成表.C1st) _
             , .Cells(GetLastR(WSリスト), CNoBOM部品構成表.CLast)).Delete xlShiftUp
    End With
    
End Sub

' 入力不備の警告
Function Is入力不備を警告する() As Boolean

    WSリスト.Activate

    If WSリスト.Range(Adrs実行パラメータ_トップアセンブリ) = "" Then
        MsgBox "トップアセンブリが入力されていません。"
        WSリスト.Range(Adrs実行パラメータ_トップアセンブリ).Select
        Is入力不備を警告する = True
        Exit Function
    End If
    
    If Match行番号(WSリスト.Range(Adrs実行パラメータ_トップアセンブリ), WSリスト.Columns(CNoPN部品リスト.部品コード)) = 0 Then
        MsgBox "トップアセンブリが部品リストにありません。"
        WSリスト.Range(Adrs実行パラメータ_トップアセンブリ).Select
        Is入力不備を警告する = True
        Exit Function
    End If

    If WSリスト.Range(Adrs実行パラメータ_数) = "" Then
        MsgBox "数が入力されていません。"
        WSリスト.Range(Adrs実行パラメータ_数).Select
        Is入力不備を警告する = True
        Exit Function
    End If

    If IsNumeric(WSリスト.Range(Adrs実行パラメータ_数)) = False Then
        MsgBox "数値で入力してください。"
        WSリスト.Range(Adrs実行パラメータ_数).Select
        Is入力不備を警告する = True
        Exit Function
    End If

End Function

標準モジュール：Ut_汎用関数

Option Explicit

' 最終行の取得
Function GetLastR(指定オブジェクト 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
    
    ' エリアの最終行を取得
    GetLastR = 対象セル範囲.Rows.Count + 対象セル範囲.Row - 1
    
    ' 列が指定されていればその列の入力最終行を取得
    If C <> -1 Then
        Do While 対象セル範囲.Worksheet.Cells(GetLastR, C) = ""
            GetLastR = GetLastR - 1
            If GetLastR < 対象セル範囲.Row Then
                GetLastR = 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

' Dictionaryを新規シートに出力する
Sub Dictionaryを新規シートに出力する(Dic As Dictionary)
    With Workbooks.Add.Worksheets(1)
        Call 配列をセルに出力する(.Range("A1"), Dic.Keys)
        Call 配列をセルに出力する(.Range("B1"), Dic.Items)
    End With
End Sub

' 1次元配列 → セル
Sub 配列をセルに出力する(出力始点セル As Range, Arr出力配列 As Variant _
    , Optional is行方向へ出力 As Boolean = True)

    If UBound(Arr出力配列) = -1 Then Exit Sub

    ' ◇ 要素数が1ならば単セルに出力
    If Count配列の要素数(Arr出力配列) = 1 Then
        出力始点セル.Value = Arr出力配列(0)

    ' Transposeで方向指定して出力
    ElseIf is行方向へ出力 Then
        出力始点セル.Resize(Count配列の要素数(Arr出力配列), 1) = Fx.Transpose(Arr出力配列)
    Else
        出力始点セル.Resize(1, Count配列の要素数(Arr出力配列)) = Fx.Transpose(Fx.Transpose(Arr出力配列))
    End If

End Sub

' 配列を新規シートに出力する
Sub 配列を新規シートに出力する(Arr)
    Workbooks.Add.Worksheets(1).Range("A1") _
        .Resize(Count配列の要素数(Arr, 1), Count配列の要素数(Arr, 2)) = Arr
End Sub

' 配列の要素数の取得
Function Count配列の要素数(Arr, Optional 次元 = 1) As Long
    Count配列の要素数 = UBound(Arr, 次元) - LBound(Arr, 次元) + 1
End Function

' 配列の次元数の取得
Function Get配列の次元数(Arr As Variant) As Long

    ' 渡された変数が配列ではない場合は0を返すこととする
    If IsArray(Arr) = False Then Get配列の次元数 = 0: Exit Function

    ' エラーが出るまでUBoundを取得してみる
    Dim tmp
    Dim 次元数 As Long: 次元数 = 0
    On Error Resume Next
    Do While Err.Number = 0
        次元数 = 次元数 + 1
        tmp = UBound(Arr, 次元数)
    Loop
    On Error GoTo 0

    ' エラーが出たひとつ前の次元が求める次元数
    Get配列の次元数 = 次元数 - 1
    
End Function

' WorksheetFunctionの短縮取得
Function Fx() As WorksheetFunction
    Set Fx = WorksheetFunction
End Function

' 自動更新の停止
Sub エクセルの自動更新を停止する(ブック計算をOFF As Boolean _
    , Optional 画面更新をOFF As Boolean = True, Optional イベントをOFF As Boolean = True _
    , Optional カーソルをOFF As Boolean = True)
    With Application
        If ブック計算をOFF Then .Calculation = xlCalculationManual
        If 画面更新をOFF Then .ScreenUpdating = False
        If イベントをOFF Then .EnableEvents = False
        If カーソルをOFF Then .Cursor = xlWait
    End With
End Sub

' 自動更新の開始
Function エクセルの自動更新を開始する()
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
        .StatusBar = False
        .DisplayAlerts = True
        .Cursor = xlDefault
    End With
    ' 合わせて検索オプションを部分一致に設定
    Call Cells.Find("", lookat:=xlPart)
End Function

コードの解説

今回の課題を回答するには「再帰関数」が必要になります。

再帰関数とは「自分自身をCallしている関数(Sub/Function)」のことで、
「指定コードを部品構成表に出力し子コードに対して再帰呼出する」が該当します。


再帰関数がどんな時に必要になるかというと、
「For文の数をどのくらい深くすればよいかが動的なとき」です。


今回の部品リストを図示すると、
部品リスト全体像
こんな風になっており、これをFor Each文で書きだしていくとなると、
再帰関数の展開イメージ
こんな風にFor Each文がネストしていくことになります。


各部品が第何階層まであるかはリストからはわかりませんので、
そういう「For文の数をどのくらい深くすればよいかが動的なとき」
に再帰関数を使うわけですね。


再帰部分だけを抽出した↓のコードをみるとなんとなくわかるかなと思います。

' 再帰関数の全体像
Sub 親コード自身を出力したあと子コードへ再帰呼出する(ByVal 親部品コード As String)

    ' まずは自身のコードを出力
    WSリスト.Cells(R_出力, CNoBOM部品構成表.部品コード) = 親部品コード
    
    ' 子コードがあれば子コードを出力
    For Each key子コード In Dic子コードリスト(親部品コード).Keys
                    
        ' 再帰部分
        Call 親コード自身を出力したあと子コードへ再帰呼出する(key子コード)
    
    Next

End Sub

このCall部分を展開していくと上記の画像になっていきますので、
見比べながら処理順を考えてみてください。


再帰呼出はプログラミングのロジックの中では相当難しいものですので、
最初にこれを見ていきなり理解するのは難易度が高いです。

自分で組みつつステップ実行しながら処理順を確かめると理解が深まりますので、
勉強したい方は是非この課題に挑戦してみてください。


再帰以外で工夫したポイントとしては、
部品の親子関係をDictionaryで定義している部分です。

' 親コードごとのDictionary[key:子コード,Item:数]
Function GetDic子コードリスト(親コード As String) As Dictionary

    ' 親コード列に対象コードがあるか検索
    Dim R_親コード As Long
    R_親コード = Match行番号(親コード, WSリスト.Columns(CNoPS構成リスト.親コード))
    If R_親コード = 0 Then Exit Function

    Set GetDic子コードリスト = New Dictionary

    ' △ 発見行から次の親コード出現行までループ
    Dim R As Long: R = R_親コード + 1
    Do
        
        ' 子コードを要素に追加
        If WSリスト.Cells(R, CNoPS構成リスト.子コード) <> "" Then
            GetDic子コードリスト.Add WSリスト.Cells(R, CNoPS構成リスト.子コード).Value _
                                           , WSリスト.Cells(R, CNoPS構成リスト.数).Value
        End If
    
        R = R + 1
        If WSリスト.Cells(R, CNoPS構成リスト.親コード) <> "" Then Exit Do
    Loop ' ▽ ' 発見行から次の親コード出現行までループ

End Function

　
この定義をしておくことで、例えば「M2-05」の子供たちをループするとき、

For Each key子コード In GetDic子コードリスト("M2-05").Keys

これだけでFor Each文を書けるようになります。


再帰のような複雑なロジックを組むときには、
こういった簡単な部分をいかに簡潔に書けるかが大事になります。

親子関係の取得をDictionary ＆ For Each で書くのは便利な方法なので、
気に入ったらこの方法を採用してみてください。


最後に細かいテクニックですが、今回の表は最終結果で階層を表すため、
階層の表記
こんな風に「ー」などを使って表現する必要があります。


この表現方法について、私は「コーディングコストを少なく」をテーマに、
「セルのインデント(文字配置)を階層分右にする」ことで実装しました。

インデントによる階層表現


この方法はコーディングが非常に簡単で、なんと↓の一行で済んでしまいます。

WSリスト.Cells(R_出力, CNoBOM部品構成表.部品コード).IndentLevel = 呼出階層


「階層構造を表現する場面」自体少ないので有用かというと難しいところですが、
覚えておくと何か使えることがあるかもしれません。

心の片隅にでも置いておいてください(´∀｀)