クロスABC分析 with Excel VBA
アウトライン
クロスABC分析は「売上金額」と「販売数量」ないし「売上金額」と「粗利額」，あるいは「売上金額」と「得意先数」など，内容の異なる2次元からのABC分析法です。1次元のABC分析では通常セグメントの数が3つですが，2次元のそれの場合は32つまり，1次元の場合の3倍になります。
もっともExcelでクロスABC分析表をつくるのは，そのシンプルな見た目からは想像もつかない程度に手数を要求されるのが関の山なので(ピボットテーブルではセグメントの内容について一覧性のある表をダイレクトに作成できません)，この頁ではマクロでそれを実現してみたいと思います。
当該マクロは，リスト形式表をピボット表で集計し，そのデータをもとにして分析表を作成するといった大枠の流れを想定して組み立てたいと思います。ただ，ピボットテーブルを利用しない場合でも，step 6と同一の構成で，項目列・第1変数の構成比・第2変数の構成比となる元表を用意すれば一応の適用が叶うようにはなっています(A3のセルを基点に配置)。
DL
(※表の見方については後述)
免責および特記項
- このマクロはあくまでデモンストレーションを目的としたものです。コードをそのままご利用いただく場合には，お手持ちのデータで従前の方法にて作成したものと内容を照合し，おかしな点が出現しないかどうかを安全な環境で十分に確認してください。精度の不足あるいは予期しないデータ消失等のトラブルにつきまして，筆者は一切責任を負いかねます。
- マクロの動作自体の検証(お使いの環境で正常に動作するか，あるいは処理にどの程度の時間がかかるかといったことの確認)には，このテストデータをExcelにコピペしてお使いいただけます。万一動作中に固まった場合は，[Ctrl]キー＋[Pause/Break]キーをお試しください。
- このマクロはここで作成するピボット表か，あるいはそれと同一の構成をもつ集計表でのみ正常に動作します。後者の場合，表最上部の見出し，表最下部の総計も必要です［step 6］。
クロスABC分析表の作成
Step 1ピボット表の作成(1)
データ領域の任意のセルをアクティブにして 挿入タブ「テーブル」グループのピボットテーブルボタンをクリックします。
Step 2ピボット表の作成(2)
「ピボットテーブルの作成」ダイアログが表示されます。対象範囲と ピボットテーブルを配置する場所が「新規ワークシート」になっていることを確認して，OKボタンをクリックします。
Step 3ピボット表の作成(3)
あたらしいシートにピボット表が作成されます。
ここでは，ABC分析の視点として
- 売上金額(以下「第1変数」)
- 販売数量(以下「第2変数」)
に注目するものとします。
ということで，フィールドリストから，「商品名」(項目として使用したい変数)を「行ラベル」枠内に，「単価」(第1変数)と「商品名」(第2変数)を「値」枠内にドラッグ＆ドロップします。
Step 4ピボット表の作成(4)
「値」枠の2変数を構成比に変更します。
まず，この枠の「合計／単価」をクリックし，ポップアップメニューから「値フィールドの設定」をクリックします。
Step 5ピボット表の作成(5)
「値フィールドの設定」ダイアログが表示されます。
計算の種類タブに切り替え，計算の種類から「列集計に対する比率」を選択します。
「値」枠内のもう一方の変数も同様に設定して構成比へ変更します。
Step 6ピボット表の作成(6)
ピボット表の各変数の見出しを適切なものに書き換えます。ここで指定したものが目的の分析表に表示されます。
Step 7VBE(Visual Basic Editor)の起動
次に，開発タブ「コード」グループのVisual Basicボタンをクリックします。
Step 8VBEの操作
VBEの挿入メニュー標準モジュールをクリックします。
Step 9VBEの操作・コードのコピー
次のコードをすべて選択し，コピーします。
Sub CROSSABCanalysis()
' *** クロスABC分析表の作成 ver.1.1.0
' *** 「クロスABC分析表の作成 with Excel」で掲載する形式で，
' *** 2変数によるピボット表をもとにクロスABC分析表を作成するマクロです。
' *** 元表は掲載の表と同じ体裁を整えている必要があります。
' *** 詳細は当該ページ(bdastyle.net/tools/abc-analysis/page3.html)をご覧ください。
' *** by hawcas 2013, 2016
On Error GoTo myError
' ※※※ AB境界, BC境界初期値
Const A1limit As Double = 0.7 ' ABクラス境界(1番目の変数)
Const B1limit As Double = 0.9 ' BCクラス境界(1番目の変数)
Const A2limit As Double = 0.7 ' ABクラス境界(2番目の変数)
Const B2limit As Double = 0.9 ' BCクラス境界(2番目の変数)
' ※※※
Dim BR As Long ' ピボット表の見出し込みの項目数を格納
Dim NoI(3, 3) As Long ' 象限(x, y)の内包する項目の数
Dim MNiR(3) As Long ' 各行の項目数のMax値
Dim EV(2) As Long ' ABC評価(変数1・変数2)
Dim cellX As Long ' 配列番号(X)
Dim cellY As Long ' 配列番号(Y)
Dim xSeries() As Variant ' データ格納用の配列
Dim CR As Variant ' 累積比率
Dim BA As String ' Range
Dim xRng As String ' Range
Dim xCtr(3, 3) As Long ' 以下カウンタ
Dim x As Long, y As Long, z As Long
' ピボット表よりデータを読み込み
BR = ActiveSheet.Range("a3").End(xlDown).Row - 3
ReDim xSeries(3, BR)
For x = 1 To 3
For y = 1 To BR
xSeries(x, y) = Range("a3").Offset(y - 1, x - 1).Value
Next
Next
' シートの追加
Worksheets.Add
' データを転記
For x = 1 To 3
For y = 1 To BR
Range("a1").Offset(y - 1, x - 1).Value = xSeries(x, y)
Next
Next
Range("d1").Value = "CR1" ' 見出しを追加
Range("e1").Value = "CR2"
Range("f1").Value = "EV1"
Range("g1").Value = "EV2"
' ［変数2］ソートと累積比率の計算
xRng = "$a$1:$g$" & BR
Range(xRng).Sort key1:=Range("c1"), order1:=xlDescending, Header:=xlYes
CR = 0
For y = 1 To BR - 1
CR = CR + Range("c1").Offset(y, 0).Value
Range("e1").Offset(y, 0).Value = CR
Next
' ［変数2］評価(1=A, 2=B, 3=C)
For y = 1 To BR - 1
If Range("e1").Offset(y, 0).Value < A2limit Then
Range("g1").Offset(y, 0).Value = 1
ElseIf Range("e1").Offset(y, 0).Value < B2limit Then
Range("g1").Offset(y, 0).Value = 2
Else
Range("g1").Offset(y, 0).Value = 3
End If
Next
' ［変数1］ソートと累積比率の計算
Range(xRng).Sort key1:=Range("b1"), order1:=xlDescending, Header:=xlYes
CR = 0
For y = 1 To BR - 1
CR = CR + Range("b1").Offset(y, 0).Value
Range("d1").Offset(y, 0).Value = CR
Next
' ［変数1］評価(1=A, 2=B, 3=C)
For y = 1 To BR - 1
If Range("d1").Offset(y, 0).Value < A1limit Then
Range("f1").Offset(y, 0).Value = 1
ElseIf Range("d1").Offset(y, 0).Value < B1limit Then
Range("f1").Offset(y, 0).Value = 2
Else
Range("f1").Offset(y, 0).Value = 3
End If
' 象限ごとに項目数をカウント
cellY = Range("f1").Offset(y, 0).Value
cellX = Range("g1").Offset(y, 0).Value
NoI(cellY, cellX) = NoI(cellY, cellX) + 1
Next
' 行ごとに列を探索して最大の項目数を取得
With Application.WorksheetFunction
MNiR(1) = .Max(NoI(1, 1), NoI(1, 2), NoI(1, 3))
MNiR(2) = .Max(NoI(2, 1), NoI(2, 2), NoI(2, 3))
MNiR(3) = .Max(NoI(3, 1), NoI(3, 2), NoI(3, 3))
End With
' 9つの象限へ項目を振り分け
For y = 1 To BR - 1
EV(1) = Range("f1").Offset(y, 0).Value
EV(2) = Range("g1").Offset(y, 0).Value
Select Case EV(1)
Case 1
Select Case EV(2)
Case 1
BA = Range("k3").Address
Case 2
BA = Range("k3").Offset(0, 3).Address
Case 3
BA = Range("k3").Offset(0, 6).Address
End Select
Case 2
Select Case EV(2)
Case 1
BA = Range("k3").Offset(MNiR(1) + 1, 0).Address
Case 2
BA = Range("k3").Offset(MNiR(1) + 1, 3).Address
Case 3
BA = Range("k3").Offset(MNiR(1) + 1, 6).Address
End Select
Case 3
Select Case EV(2)
Case 1
BA = Range("k3").Offset(MNiR(1) + MNiR(2) + 2, 0).Address
Case 2
BA = Range("k3").Offset(MNiR(1) + MNiR(2) + 2, 3).Address
Case 3
BA = Range("k3").Offset(MNiR(1) + MNiR(2) + 2, 6).Address
End Select
End Select
xCtr(EV(1), EV(2)) = xCtr(EV(1), EV(2)) + 1
Range(BA).Offset(xCtr(EV(1), EV(2)) - 1, 0).Value = Range("a1").Offset(y, 1).Value
Range(BA).Offset(xCtr(EV(1), EV(2)) - 1, 1).Value = Range("a1").Offset(y, 0).Value
Range(BA).Offset(xCtr(EV(1), EV(2)) - 1, 2).Value = Range("a1").Offset(y, 2).Value
Next
' 外周罫の描画
With Range(Range("i1").Address, Range("s1").Offset(MNiR(1) + MNiR(2) + MNiR(3) + 4, 0).Address)
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
End With
' 横罫の描画
With Range(Range("i1").Offset(1, 0).Address, Range("s1").Offset(1, 0).Address)
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
End With
With Range(Range("i1").Offset(2, 0).Address, Range("s1").Offset(MNiR(1) + 2, 0).Address)
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
End With
With Range(Range("i1").Offset(MNiR(1) + MNiR(2) + 3, 0).Address, Range("s1").Offset(MNiR(1) + MNiR(2) + 3, 0).Address)
.Borders(xlEdgeBottom).LineStyle = xlContinuous
End With
' 縦罫の描画
With Range(Range("i1").Offset(0, 1).Address, Range("i1").Offset(MNiR(1) + MNiR(2) + MNiR(3) + 4, 1).Address)
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
End With
With Range(Range("i1").Offset(0, 5).Address, Range("i1").Offset(MNiR(1) + MNiR(2) + MNiR(3) + 4, 7).Address)
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
End With
' 表側頭罫線の削除
Range("$i$1:$j$2").Borders(xlInsideVertical).LineStyle = xlLineStyleNone
Range("$i$1:$j$2").Borders(xlInsideHorizontal).LineStyle = xlLineStyleNone
' 変数1のデータバーをセット
z = MNiR(1) + MNiR(2) + MNiR(3) + 5
xRng = "$k$3:$k$" & z & ",$n$3:$n$" & z & ",$q$3:$q$" & z
With Range(xRng)
.FormatConditions.AddDatabar
.FormatConditions(.FormatConditions.Count).ShowValue = False
.FormatConditions(.FormatConditions.Count).SetFirstPriority
End With
With Range(xRng).FormatConditions(1)
'.MinPoint.Modify newtype:=xlConditionValueAutomaticMin ' 最大構成比の項目=1とする場合
'.MaxPoint.Modify newtype:=xlConditionValueAutomaticMax
.MinPoint.Modify newtype:=xlConditionValueNumber, newvalue:=0 ' 全体=1とする場合
.MaxPoint.Modify newtype:=xlConditionValueNumber, newvalue:=1
End With
With Range(xRng).FormatConditions(1).BarColor
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0.25
End With
With Range(xRng).FormatConditions(1)
.BarFillType = xlDataBarFillSolid
.Direction = xlRTL
.BarBorder.Type = xlDataBarBorderNone
End With
' 変数2のデータバーをセット
xRng = "$m$3:$m$" & z & ",$p$3:$p$" & z & ",$s$3:$s$" & z
With Range(xRng)
.FormatConditions.AddDatabar
.FormatConditions(.FormatConditions.Count).ShowValue = False
.FormatConditions(.FormatConditions.Count).SetFirstPriority
End With
With Range(xRng).FormatConditions(1)
'.MinPoint.Modify newtype:=xlConditionValueAutomaticMin ' 最大構成比の項目=1とする場合
'.MaxPoint.Modify newtype:=xlConditionValueAutomaticMax
.MinPoint.Modify newtype:=xlConditionValueNumber, newvalue:=0 ' 全体=1とする場合
.MaxPoint.Modify newtype:=xlConditionValueNumber, newvalue:=1
End With
With Range(xRng).FormatConditions(1).BarColor
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.35
End With
With Range(xRng).FormatConditions(1)
.BarFillType = xlDataBarFillSolid
.Direction = xlLTR
.BarBorder.Type = xlDataBarBorderNone
End With
' 項目部分の彩色
xRng = "$l$3:$l$" & z & ",$o$3:$o$" & z & ",$r$3:$r$" & z
With Range(xRng).Interior
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.05
End With
' 見出しの作成
xRng = "$i$3:$i$" & z
Range(xRng).MergeCells = True
With Range("i3")
.Orientation = xlVertical
.VerticalAlignment = xlTop
End With
Range("i3").Value = Range("b1").Value
Range("$k$1:$s$1").MergeCells = True
Range("k1").Value = Range("c1").Value
With Range("j2")
.Offset(1, 0) = "A"
.Offset(1 + MNiR(1) + 1, 0) = "B"
.Offset(1 + MNiR(1) + MNiR(2) + 2, 0) = "C"
.Offset(0, 1) = "A"
.Offset(0, 4) = "B"
.Offset(0, 7) = "C"
End With
' 目的の表以外の要素を削除
Columns("A:H").Delete
Exit Sub
myError:
MsgBox "実行時エラーが発生しました。処理を終了します。"
End Sub
Step 10VBEの操作・コードの貼り付け
「標準モジュール」ウインドウにコードを貼り付けます。
Step 11VBEの操作・パラメータの設定
境界前後の項目の構成比などを勘案して(たとえば，同じ構成比なのにBCクラスに分かれることに意味があるか，など)，必要に応じてABCクラス分けの境界(下のパレート図でいう「Axlimit」と「Bxlimit」)を変更します。
初期値は0.7(70%)がAクラスとBクラスの境界に，0.9(90%)がBクラスとCクラスの境界になっています。これを修正する場合，コードの先頭方向にある「※」で囲まれた定数を直接変更します(小数表記で)。これは第1変数・第2変数と独立して指定できます。
参考)パレート図
Step 12VBEの操作
閉じるボタンをクリックしてVBEを閉じます。
Step 13マクロの実行(1) “CROSSABCanalysis”
マクロを実行する前にピボット表をアクティブな状態にしておきます。
次に 開発タブ「コード」グループのマクロボタンをクリックします。
Step 14マクロの実行(2) “CROSSABCanalysis”
「マクロ」ダイアログが表示されます。
マクロ名に「CROSSABCanalysis」が表示されていることを確認して，実行ボタンをクリックします。
Step 15クロスABC分析表・完成
あたらしいシートが追加され，ピボット表をもとにしてクロスABC分析表が作成されます。
縦方向が第1変数，横方向が第2変数のABCクラスをあらわしています。各クラスには項目名(ここでは商品名)が自動的に振り分けられます。項目名の左側横棒線は，デフォルトでは第1変数のパレート図の棒部分，すなわち全体に占める当該項目の割合をあらわします。同じく右側横棒線は第2変数のパレート図の棒をあらわします。項目は各クラスごとに第1変数の降順で並べられます。
書式などを任意に調整してクロスABC分析表の完成です。
