VBA100本ノック 88本目:クロスABC分析作成
売上データと商品マスタからクロスABC分析を作成する問題です。
ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。
出題
「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分析なので一般的には件数も限られた範囲になります。
したがって、速度はさほど気にしなくても良いとは思います。
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は記事補足に掲載しました。
補足
そのような場合の修正の手間を減らすにはEnum列挙を使う方法は簡単で良いと思います。
列位置が変更になる可能性が高い場合には、まずはEnumの使用を検討してみてください。
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
サイト内関連ページ
同じテーマ「VBA100本ノック」の記事
85本目:請求日から入金予定日を算出
86本目:全シートの総当たり表を作成
87本目:数式のシート間の依存関係
88本目:クロスABC分析作成
89本目:2つのフォルダの統合
90本目:セルに重なっている画像の削除
91本目:時間計算(残業時間の月間合計)
92本目:セルの色を16進で返す関数
93本目:複数ブックを連結して再分割
94本目:表範囲からHTMLのtableタグを作成
95本目:図形のテキストを検索するフォーム作成
新着記事NEW ・・・新着記事一覧を見る
TRIMRANGE関数(セル範囲をトリム:端の空白セルを除外)|エクセル入門(2024-08-30)
正規表現関数(REGEXTEST,REGEXREPLACE,REGEXEXTRACT)|エクセル入門(2024-07-02)
エクセルが起動しない、Excelが立ち上がらない|エクセル雑感(2024-04-11)
ブール型(Boolean)のis変数・フラグについて|VBA技術解説(2024-04-05)
テキストの内容によって図形を削除する|VBA技術解説(2024-04-02)
ExcelマクロVBA入門目次|エクセルの神髄(2024-03-20)
VBA10大躓きポイント(初心者が躓きやすいポイント)|VBA技術解説(2024-03-05)
テンキーのスクリーンキーボード作成|ユーザーフォーム入門(2024-02-26)
無効な前方参照か、コンパイルされていない種類への参照です。|エクセル雑感(2024-02-17)
初級脱出10問パック|VBA練習問題(2024-01-24)
アクセスランキング ・・・ ランキング一覧を見る
1.最終行の取得(End,Rows.Count)|VBA入門
2.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
3.繰り返し処理(For Next)|VBA入門
4.変数宣言のDimとデータ型|VBA入門
5.RangeとCellsの使い方|VBA入門
6.ブックを閉じる・保存(Close,Save,SaveAs)|VBA入門
7.メッセージボックス(MsgBox関数)|VBA入門
8.セルのクリア(Clear,ClearContents)|VBA入門
9.ブック・シートの選択(Select,Activate)|VBA入門
10.条件分岐(Select Case)|VBA入門
- ホーム
- マクロVBA入門編
- VBA100本ノック
- 88本目:クロスABC分析作成
このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。