88本目：クロスABC分析作成

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

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

出題：クロスABC分析作成

#VBA100本ノック 88本目
「data」と「商品マスタ」から「クロスABC」を完成させる。
・仕入金額=仕入単価*数量
・売上金額=販売単価*数量
・粗利金額=売上金額-仕入金額
・売上ABC=売上順に並べ累計構成比が、<=50%がA、<=90%がB、以外はC
・粗利ABC=粗利順で売上ABCと同様に
※最後は売上順で

◇ 出題ページはこちら

ソースコード

定義モジュール

Option Explicit

' ABCライン
Public Const 累計比率Aライン = 0.5
Public Const 累計比率Bライン = 0.9

' data
Public Const R1stdata = 2
Public Const C1stdata = 1
Public Enum CNodata
    コード = C1stdata
    数量
End Enum
Public Const CLastdata = CNodata.数量

' 商品マスタ (※1)マジックナンバー数式有
Public Const R1st商品マスタ = 2
Public Const C1st商品マスタ = 1
Public Enum CNo商品マスタ
    コード = C1st商品マスタ
    品名
    仕入単価
    販売単価
End Enum
Public Const CLast商品マスタ = CNo商品マスタ.販売単価

' クロスABC (※2)マジックナンバー数式有
Public Const R1stクロスABC = 2
Public Const C1stクロスABC = 1
Public Enum CNoクロスABC
    コード = C1stクロスABC
    品名
    数量
    仕入単価
    販売単価
    仕入金額
    売上金額
    粗利金額
    売上ABC
    粗利ABC
    追加_累計売上
    追加_累計粗利
End Enum
Public Const CLastクロスABC = CNoクロスABC.粗利ABC

メインモジュール

Option Explicit

' 100本ノック088：クロスABC分析作成
Sub ★クロスABC分析表を作成する()
    
    Call 指定行より下をすべて削除する(WSクロスABC, R1stクロスABC)
    
    ' dataシートから全データを転記
    Call 値をコピーする(GetRange指定列のデータ部分(WSdata, CNodata.コード) _
                            , WSクロスABC.Cells(R1stクロスABC, CNoクロスABC.コード))
    Call 値をコピーする(GetRange指定列のデータ部分(WSdata, CNodata.数量) _
                            , WSクロスABC.Cells(R1stクロスABC, CNoクロスABC.数量))

    ' 商品マスタの反映 (※1)マジックナンバー数式有
    Call シート数式で計算する(GetRange指定列のデータ部分(WSクロスABC _
        , CNoクロスABC.品名), "=VLOOKUP($A2,商品マスタ!$A:$D,2,FALSE)")
    Call シート数式で計算する(GetRange指定列のデータ部分(WSクロスABC _
        , CNoクロスABC.仕入単価), "=VLOOKUP($A2,商品マスタ!$A:$D,3,FALSE)")
    Call シート数式で計算する(GetRange指定列のデータ部分(WSクロスABC _
        , CNoクロスABC.販売単価), "=VLOOKUP($A2,商品マスタ!$A:$D,4,FALSE)")
        
    ' 仕入金額と売上金額の計算 (※2)マジックナンバー数式有
    Call シート数式で計算する(GetRange指定列のデータ部分(WSクロスABC _
        , CNoクロスABC.仕入金額), "=C2*D2")
    Call シート数式で計算する(GetRange指定列のデータ部分(WSクロスABC _
        , CNoクロスABC.売上金額), "=C2*E2")
    Call シート数式で計算する(GetRange指定列のデータ部分(WSクロスABC _
        , CNoクロスABC.粗利金額), "=G2-F2")
        
    ' 作業列を追加してフィルターを付けなおす
    WSクロスABC.Columns(CNoクロスABC.追加_累計売上).Insert
    WSクロスABC.Cells(R1stクロスABC - 1, CNoクロスABC.追加_累計売上) = "累計売上"
    WSクロスABC.Columns(CNoクロスABC.追加_累計粗利).Insert
    WSクロスABC.Cells(R1stクロスABC - 1, CNoクロスABC.追加_累計粗利) = "累計粗利"
    WSクロスABC.AutoFilterMode = False
    WSクロスABC.Rows(R1stクロスABC - 1).AutoFilter
    
    Dim データエリア As Range
    Set データエリア = GetRangeフィルターデータ部分(WSクロスABC)
    
    ' 売上順にソートして累計売上を計算 (※2)マジックナンバー数式有
    データエリア.Sort WSクロスABC.Cells(1, CNoクロスABC.売上金額), xlDescending
    Call シート数式で計算する(GetRange指定列のデータ部分(WSクロスABC _
        , CNoクロスABC.追加_累計売上), "=SUM($G$2:G2)")
        
    ' 売上ABCを算定 (※2)マジックナンバー数式有
    Dim 合計売上 As Long: 合計売上 = Fx.Sum(GetRange指定列のデータ部分(WSクロスABC, CNoクロスABC.売上金額))
    Dim Aライン As Double, Bライン As Double
    Aライン = 合計売上 * 累計比率Aライン
    Bライン = 合計売上 * 累計比率Bライン
    Call シート数式で計算する(GetRange指定列のデータ部分(WSクロスABC _
        , CNoクロスABC.売上ABC), "=IFS(K2<=" & Aライン & ",""A"",K2<=" & Bライン & ",""B"",TRUE,""C"")")
    
    ' 粗利順にソートして累計粗利を計算 (※2)マジックナンバー数式有
    データエリア.Sort WSクロスABC.Cells(1, CNoクロスABC.粗利金額), xlDescending
    Call シート数式で計算する(GetRange指定列のデータ部分(WSクロスABC _
        , CNoクロスABC.追加_累計粗利), "=SUM($H$2:H2)")
        
    ' 粗利ABCを算定 (※2)マジックナンバー数式有
    Dim 合計粗利 As Long: 合計粗利 = Fx.Sum(GetRange指定列のデータ部分(WSクロスABC, CNoクロスABC.粗利金額))
    Aライン = 合計粗利 * 累計比率Aライン
    Bライン = 合計粗利 * 累計比率Bライン
    Call シート数式で計算する(GetRange指定列のデータ部分(WSクロスABC _
        , CNoクロスABC.粗利ABC), "=IFS(L2<=" & Aライン & ",""A"",L2<=" & Bライン & ",""B"",TRUE,""C"")")
    
    ' 売上順にソートしなおし
    データエリア.Sort WSクロスABC.Cells(1, CNoクロスABC.売上金額), xlDescending
    
    ' 作業列を削除
    WSクロスABC.Columns(CNoクロスABC.追加_累計粗利).Delete
    WSクロスABC.Columns(CNoクロスABC.追加_累計売上).Delete
        
    MsgBox "クロスABC分析表の作成を完了しました。"
        
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/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/utility/get-autofilter-datarange
Function GetRangeフィルターデータ部分(指定シート As Worksheet) As Range
    If 指定シート.AutoFilterMode = False Then Exit Function
    
    Dim フィルターデータ部 As Range
    Set フィルターデータ部 = 指定シート.AutoFilter.Range
    
    If フィルターデータ部.Rows.Count = 1 Then Exit Function
    
    Set フィルターデータ部 = フィルターデータ部.Offset(1)
    Set フィルターデータ部 = フィルターデータ部.Resize(フィルターデータ部.Rows.Count - 1)
    
    Set GetRangeフィルターデータ部分 = フィルターデータ部

End Function

' データ件数
' ◆ ブログ未掲載
Function Countデータ件数(対象シート As Worksheet) As Long
    If 対象シート.AutoFilterMode = False Then Exit Function
    With 対象シート.AutoFilter.Range
        Countデータ件数 = .Rows.Count + .Row - 2
    End With
End Function

' 各列のデータ部分
' 参考：https://www.limecode.jp/entry/utility/get-column-data-range
Function GetRange指定列のデータ部分(対象シート As Worksheet, 対象列 As Long) As Range
    If Countデータ件数(対象シート) = 0 Then Exit Function
    Set GetRange指定列のデータ部分 = 対象シート.Cells(対象シート.AutoFilter.Range.Row + 1, 対象列) _
                                                            .Resize(Countデータ件数(対象シート))
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

' シート数式計算
' 参考：https://www.limecode.jp/entry/syntax/formula
Sub シート数式で計算する(計算エリア As Range, シート数式 As String)
    計算エリア.Formula = シート数式
    計算エリア.Value = 計算エリア.Value
End Sub

解説

Formula無双回ですね。

Formulaプロパティを使用することで、
お手軽に高速処理コードを書くことができます。

普通にFor文で処理するのに比べて、
Rangeへのアクセス回数が1回(値貼り付けで2回)で済みますからね。

詳細についてはこちらの記事をご覧ください。

また、このFormulaを使ったコードを書く時は、

• セル範囲.Formulaで計算
• セル範囲.Value=セル範囲.Valueで値貼付

このように同じセル範囲が3回も出てきます。

この時、↓こちらの関数を持っておくと地味ながら非常に便利です。

Sub シート数式で計算する(計算エリア As Range, シート数式 As String)
    計算エリア.Formula = シート数式
    計算エリア.Value = 計算エリア.Value
End Sub

積極的にご活用ください。

最後に、Formulaを使用する際のマジックナンバー対策ですが、
以下のコードを比較してみましょう。

セル範囲.Formula = "=C2*D2"

セル範囲.Formula = "=" & Cells(R1stクロスABC, CNoクロスABC.数量).Address(0, 0) & "*" & Cells(R1stクロスABC, CNoクロスABC.仕入単価).Address(0, 0)

　
行列の挿入時にメンテが不要というメリットを差し引いても、
流石にEnumを利用するコーディングコストが高すぎますよね。

しかも読みやすいかというとそんなこともなく、
大事な「掛け算であることを示す*」が読み取りづらくなります。

こんな時は、今回のコードのように、
(※1)(※2)などのマークを付けておくのがおすすめです。

' ◆ 定義モジュール

' クロスABC (※2)マジックナンバー数式有
Public Const R1stクロスABC = 2
Public Const C1stクロスABC = 1

' ◆ メインロジック

' 仕入金額と売上金額の計算 (※2)マジックナンバー数式有
Call シート数式で計算する(GetRange指定列のデータ部分(WSクロスABC _
    , CNoクロスABC.仕入金額), "=C2*D2")

　
これなら「Enumをいじるだけでは改修が済まない」ことは伝わりますし、
その上でコードを書き換えるコストはEnumで書くコスト以下でしょう。

この方法も手軽でおすすめですので是非ともご活用ください。