VBA100本ノック 88本目：クロスABC分析作成
売上データと商品マスタからクロスABC分析を作成する問題です。
ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。
マクロVBAを初心者向けの基本から上級者向けの高度な内容までサンプルコードを掲載し解説しています。エクセル関数・機能・基本操作の入門解説からマクロVBAまでエクセル全般を網羅しています。
出題
出題ツイートへのリンク
#VBA100本ノック 88本目
「data」と「商品マスタ」から「クロスABC」を完成させる。
・仕入金額=仕入単価*数量
・売上金額=販売単価*数量
・粗利金額=売上金額-仕入金額
・売上ABC=売上順に並べ累計構成比が、<=50%がA、<=90%がB、以外はC
・粗利ABC=粗利順で売上ABCと同様に
※最後は売上順で
サンプルファイルです。
https://excel-ubara.com/vba100sample/VBA100_88.xlsm
https://excel-ubara.com/vba100sample/VBA100_88.zip
「data」と「商品マスタ」から「クロスABC」を完成させる。
・仕入金額=仕入単価*数量
・売上金額=販売単価*数量
・粗利金額=売上金額-仕入金額
・売上ABC=売上順に並べ累計構成比が、<=50%がA、<=90%がB、以外はC
・粗利ABC=粗利順で売上ABCと同様に
※最後は売上順で
https://excel-ubara.com/vba100sample/VBA100_88.xlsm
https://excel-ubara.com/vba100sample/VBA100_88.zip
VBA作成タイム
この下に頂いた回答へのリンクと解説を掲載しています。
途中まででも良いので、できるだけ自分でVBAを書いてみましょう。
他の人の回答および解説を見て、書いたVBAを見直してみましょう。
頂いた回答
解説
転記、マスタ情報取得、計算、並べ替え、集計
いろいろな要素が入っています。
これがさくっと書ければ、転記系のVBAは大丈夫でしょう。
今回はABC分析なので一般的には件数も限られた範囲になります。
したがって、速度はさほど気にしなくても良いとは思います。
列数が多くレイアウト変更があるような場合はEnum列挙の使用も考えたいところです。
また、マスタ情報取得も1件ずつではなくセルに数式を入れて一括で取得する方法も考えたいところです。
このVBAは記事補足に掲載しました。
いろいろな要素が入っています。
これがさくっと書ければ、転記系のVBAは大丈夫でしょう。
今回はABC分析なので一般的には件数も限られた範囲になります。
したがって、速度はさほど気にしなくても良いとは思います。
Sub VBA100_88_01()
Dim wsABC As Worksheet: Set wsABC = Worksheets("クロスABC")
Dim wsMst As Worksheet: Set wsMst = Worksheets("商品マスタ")
Dim wsDat As Worksheet: Set wsDat = Worksheets("data")
Application.ScreenUpdating = False
wsABC.Range("A1").CurrentRegion.Offset(1).ClearContents
Dim rngMst As Range
Set rngMst = wsDat.Range("A1").CurrentRegion
Set rngMst = Intersect(rngMst, rngMst.Offset(1))
wsABC.Cells(2, 1).Resize(rngMst.Rows.Count).Value = rngMst.Columns(1).Value
wsABC.Cells(2, 3).Resize(rngMst.Rows.Count).Value = rngMst.Columns(2).Value
Dim rngABC As Range
Set rngABC = wsABC.Range("A1").CurrentRegion
Set rngABC = Intersect(rngABC, rngABC.Offset(1))
Dim i As Long, ix As Long, ary
With rngABC
For i = 1 To rngABC.Rows.Count
On Error Resume Next
ix = WorksheetFunction.Match(.Cells(i, 1), wsMst.Columns(1), 0)
If Err.Number = 0 Then
ary = .Cells(i, 1).Resize(, 8).Value
ary(1, 2) = wsMst.Cells(ix, 2).Value
ary(1, 4) = wsMst.Cells(ix, 3).Value
ary(1, 5) = wsMst.Cells(ix, 4).Value
ary(1, 6) = ary(1, 3) * ary(1, 4)
ary(1, 7) = ary(1, 3) * ary(1, 5)
ary(1, 8) = ary(1, 7) - ary(1, 6)
.Cells(i, 1).Resize(, 8).Value = ary
End If
Next
Call setAbc(rngABC, 8, 10)
Call setAbc(rngABC, 7, 9)
End With
Application.ScreenUpdating = True
End Sub
Sub setAbc(ByVal rngABC As Range, aColPice As Long, aColABC As Long)
rngABC.Sort Key1:=rngABC.Cells(1, aColPice), order1:=xlDescending, Header:=xlNo
Dim i As Long, total As Double, subtotal As Double
total = WorksheetFunction.Sum(rngABC.Columns(aColPice))
subtotal = 0
For i = 1 To rngABC.Rows.Count
subtotal = subtotal + rngABC.Cells(i, aColPice)
Select Case subtotal / total
Case Is <= 0.5: rngABC.Cells(i, aColABC).Value = "A"
Case Is <= 0.9: rngABC.Cells(i, aColABC).Value = "B"
Case Else: rngABC.Cells(i, aColABC).Value = "C"
End Select
Next
End Sub
また、マスタ情報取得も1件ずつではなくセルに数式を入れて一括で取得する方法も考えたいところです。
このVBAは記事補足に掲載しました。
補足
「クロスABC」のシートは列位置等が変更になる事もありそうです。
そのような場合の修正の手間を減らすにはEnum列挙を使う方法は簡単で良いと思います。
そのような場合の修正の手間を減らすにはEnum列挙を使う方法は簡単で良いと思います。
列位置を自動取得するように出来ればより良いのですが、何らかの制約も必要になりますし、VBAもより複雑になります。
列位置が変更になる可能性が高い場合には、まずはEnumの使用を検討してみてください。
列位置が変更になる可能性が高い場合には、まずはEnumの使用を検討してみてください。
マスタから情報を取得するには、MATCH関数またはVLOOKUP関数を使う事が多くなりますが、
1件ずつ取得すると、どうしても処理時間がかかるようになってしまいます。
セルに一括で数式を入れてから.Value = .Valueで値だけにする方法は速度面で有効です。
1件ずつ取得すると、どうしても処理時間がかかるようになってしまいます。
セルに一括で数式を入れてから.Value = .Valueで値だけにする方法は速度面で有効です。
Enum colABC
コード = 1
品名
数量
仕入単価
販売単価
仕入金額
売上金額
粗利金額
売上ABC
粗利ABC
End Enum
Sub VBA100_88_02()
Dim wsABC As Worksheet: Set wsABC = Worksheets("クロスABC")
Dim wsMst As Worksheet: Set wsMst = Worksheets("商品マスタ")
Dim wsDat As Worksheet: Set wsDat = Worksheets("data")
Application.ScreenUpdating = False
wsABC.Range("A1").CurrentRegion.Offset(1).ClearContents
Dim rngMst As Range
Set rngMst = wsDat.Range("A1").CurrentRegion
Set rngMst = Intersect(rngMst, rngMst.Offset(1))
wsABC.Cells(2, colABC.コード).Resize(rngMst.Rows.Count).Value = rngMst.Columns(1).Value
wsABC.Cells(2, colABC.数量).Resize(rngMst.Rows.Count).Value = rngMst.Columns(2).Value
Dim rngABC As Range
Set rngABC = wsABC.Range("A1").CurrentRegion
Set rngABC = Intersect(rngABC, rngABC.Offset(1))
With rngABC
.Columns(colABC.品名).Formula = "=IFERROR(VLOOKUP(A2,商品マスタ!A:D,2,0),"""")"
.Columns(colABC.仕入単価).Formula = "=IFERROR(VLOOKUP(A2,商品マスタ!A:D,3,0),"""")"
.Columns(colABC.販売単価).Formula = "=IFERROR(VLOOKUP(A2,商品マスタ!A:D,4,0),"""")"
.Columns(colABC.仕入金額).Formula = "=IFERROR(RC[" & colABC.数量 - colABC.仕入金額 & "]" & _
"*RC[" & colABC.仕入単価 - colABC.仕入金額 & "],0)"
.Columns(colABC.売上金額).Formula = "=IFERROR(RC[" & colABC.数量 - colABC.売上金額 & "]" & _
"*RC[" & colABC.販売単価 - colABC.売上金額 & "],0)"
.Columns(colABC.粗利金額).Formula = "=IFERROR(RC[" & colABC.売上金額 - colABC.粗利金額 & "]" & _
"-RC[" & colABC.仕入金額 - colABC.粗利金額 & "],0)"
.Value = .Value
End With
Call setAbc(rngABC, colABC.粗利金額, colABC.粗利ABC)
Call setAbc(rngABC, colABC.売上金額, colABC.売上ABC)
Application.ScreenUpdating = True
End Sub
Sub setAbc(ByVal rngABC As Range, aColPice As Long, aColABC As Long)
rngABC.Sort Key1:=rngABC.Cells(1, aColPice), order1:=xlDescending, Header:=xlNo
Dim i As Long, total As Double, subtotal As Double
total = WorksheetFunction.Sum(rngABC.Columns(aColPice))
subtotal = 0
For i = 1 To rngABC.Rows.Count
subtotal = subtotal + rngABC.Cells(i, aColPice)
Select Case subtotal / total
Case Is <= 0.5: rngABC.Cells(i, aColABC).Value = "A"
Case Is <= 0.9: rngABC.Cells(i, aColABC).Value = "B"
Case Else: rngABC.Cells(i, aColABC).Value = "C"
End Select
Next
End Sub
サイト内関連ページ
第38回．セルに計算式を設定（Formula）
・計算式を設定できるプロパティ ・Valueプロパティ ・Formulaプロパティ , FormulaLocalプロパティ ・FormulaR1C1プロパティ , FormulaR1C1Localプロパティ ・R1C1参照形式 ・Localが付くプロパティについて ・それぞれの違い（Localは除く） ・何故、こんなに多くのプロパティが存在しているのか ・R1C1形式を使うメリット ・たった1行のVBAで複数のセルに計算式を入れる
第41回．セルのコピー&値の貼り付け（PasteSpecial）・PasteSpecialメソッド ・値の貼り付け ・いろいろなコピーのVBAの書き方 ・PasteSpecialの使用例 ・最後に
第42回．セルをコピーするとは・セルをコピーするとは ・上記方法ではコピーできないプロパティ ・.Valueのセル範囲間のコピー ・.Value以外の場合は、セル範囲をセル範囲にコピーは出来ません ・コピー方法の使い分け ・セルのコピー（Copyメソッド）実行時の注意点 ・最後に
第88回．並べ替え（Sort）・Range.Sortメソッド・・・Excel2003までのソート ・2007以降の並べ替え ・Excel2003までのSortとExcel2007以降のSortの使い分け
同じテーマ「VBA100本ノック」の記事
85本目：請求日から入金予定日を算出
86本目：全シートの総当たり表を作成
87本目：数式のシート間の依存関係
88本目：クロスABC分析作成
89本目：2つのフォルダの統合
90本目：セルに重なっている画像の削除
91本目：時間計算（残業時間の月間合計）
92本目：セルの色を16進で返す関数
93本目：複数ブックを連結して再分割
94本目：表範囲からHTMLのtableタグを作成
95本目：図形のテキストを検索するフォーム作成
新着記事NEW ・・・新着記事一覧を見る
AIは便利なはずなのに…「AI疲れ」が次の社会問題になる｜生成AI活用研究(2026-02-16)
カンマ区切りデータの行展開｜エクセル練習問題(2026-01-28)
開いている「Excel/Word/PowerPoint」ファイルのパスを調べる方法｜エクセル雑感(2026-01-27)
IMPORTCSV関数（CSVファイルのインポート）｜エクセル入門(2026-01-19)
IMPORTTEXT関数（テキストファイルのインポート）｜エクセル入門(2026-01-19)
料金表（マトリックス）から金額で商品を特定する｜エクセル練習問題(2026-01-14)
「緩衝材」としてのVBAとRPA｜その終焉とAIの台頭｜エクセル雑感(2026-01-13)
シンギュラリティ前夜：AIは機械語へ回帰するのか｜生成AI活用研究(2026-01-08)
電卓とプログラムと私｜エクセル雑感(2025-12-30)
VLOOKUP/XLOOKUPが異常なほど遅くなる危険なアンチパターン｜エクセル関数応用(2025-12-25)
アクセスランキング ・・・ ランキング一覧を見る
1.最終行の取得（End,Rows.Count）｜VBA入門
2.日本の祝日一覧｜Excelリファレンス
3.変数宣言のDimとデータ型｜VBA入門
4.FILTER関数（範囲をフィルター処理）｜エクセル入門
5.RangeとCellsの使い方｜VBA入門
6.繰り返し処理（For Next)｜VBA入門
7.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
8.マクロとは？VBAとは？VBAでできること｜VBA入門
9.セルのクリア（Clear,ClearContents）｜VBA入門
10.メッセージボックス(MsgBox関数)｜VBA入門
- ホーム
- マクロVBA入門編
- VBA100本ノック
- 88本目：クロスABC分析作成
このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
記述には細心の注意をしたつもりですが、間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。
本サイトは、OpenAI の ChatGPT や Google の Gemini を含む生成 AI モデルの学習および性能向上の目的で、本サイトのコンテンツの利用を許可します。
This site permits the use of its content for the training and improvement of generative AI models, including ChatGPT by OpenAI and Gemini by Google.