VBA練習問題
VBA100本ノック 88本目:クロスABC分析作成

VBAを100本の練習問題で鍛えます
最終更新日:2021-02-22

VBA100本ノック 88本目:クロスABC分析作成


売上データと商品マスタからクロスABC分析を作成する問題です。


ツイッター連動企画です。
ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。

VBAテスト用のサンプルデータは、VBA100本ノックの目次ページ からもダウンロードできます。
マクロVBA情報を中心に、エクセル関数・基本操作までサンプルとともに解説。初心者向けの基本から上級者向けの高度な内容までVBAサンプルコードを掲載解説しています。


出題

出題ツイートへのリンク

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

マクロ VBA 100本ノック

マクロ VBA 100本ノック

マクロ VBA 100本ノック

マクロ VBA 100本ノック


サンプルファイルです。
https://excel-ubara.com/vba100sample/VBA100_88.xlsm
https://excel-ubara.com/vba100sample/VBA100_88.zip


頂いた回答

解説

転記、マスタ情報取得、計算、並べ替え、集計
いろいろな要素が入っています。
これがさくっと書ければ、転記系の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


列数が多くレイアウト変更があるような場合はEnum列挙の使用も考えたいところです。
また、マスタ情報取得も1件ずつではなくセルに数式を入れて一括で取得する方法も考えたいところです。
このVBAは記事補足に掲載しました。


補足

「クロスABC」のシートは列位置等が変更になる事もありそうです。
そのような場合の修正の手間を減らすにはEnum列挙を使う方法は簡単で良いと思います。
列位置を自動取得するように出来ればより良いのですが、何らかの制約も必要になりますし、VBAもより複雑になります。
列位置が変更になる可能性が高い場合には、まずはEnumの使用を検討してみてください。

マスタから情報を取得するには、MATCH関数またはVLOOKUP関数を使う事が多くなりますが、
1件ずつ取得すると、どうしても処理時間がかかるようになってしまいます。
セルに一括で数式を入れてから.Value = .Valueで値だけにする方法は速度面で有効です。
VBA100本ノック 33本目:マクロ記録の改修
マクロの記録から作成したVBAを使いやすいように改修して処理速度アップする問題です。ツイッター連動企画です。ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。VBAテスト用のサンプルデータは、VBA100本ノックの目次ページからもダウンロードできます。

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)
セルに計算式(関数)を設定する場合のマクロVBAになります。マクロでは、セルに計算式を設定することは、そんなに多くないと思いますが、決して使わないわけではありません。しかし、この計算式の設定には何種類ものプロパティがあり、結構やっかいなのです。
第41回.セルのコピー&値の貼り付け(PasteSpecial)
値の貼り付けと題しましたが、値だけではなく、「形式を選択して貼り付け」のいろいろな指定方法です。セルをコピーして、他のセルに「形式を選択して貼り付け」する場合のマクロVBAコードです。セルの値や書式を別のセルにコピーすることはマクロVBAでは定番かつ必須の技術になります。
第42回.セルをコピーするとは
セルをコピーするとは、どういう事でしょうか… セルをコピーするというマクロVBAを少し掘り下げて考えることで、より実践的なマクロVBAコードを書くことが出来るようになります。コピーと一言で言っているものは、何のコピーを指しているのでしょうか。
第88回.並べ替え(Sort)
並べ替えは、データ処理の基本中の基本です、乱雑なデータを並べ替えることは、データ処理の第一歩です。マクロVBAで並べ替えを実行するには、シート操作の「並べ替え」の機能を使用することになります。そもそもデータを並べ替えるという事は、そのデータのキーが何かを考えるという事です。




同じテーマ「VBA100本ノック」の記事

85本目:請求日から入金予定日を算出
86本目:全シートの総当たり表を作成
87本目:数式のシート間の依存関係
88本目:クロスABC分析作成
89本目:2つのフォルダの統合
90本目:セルに重なっている画像の削除
91本目:時間計算(残業時間の月間合計)
92本目:セルの色を16進で返す関数
93本目:複数ブックを連結して再分割
魔球編:組み合わせ問題
魔球編:閉領域の塗り潰し


新着記事NEW ・・・新着記事一覧を見る

VBA100本ノック 93本目:複数ブックを連結して再分割|VBA練習問題(2月22日)
VBA100本ノック 92本目:セルの色を16進で返す関数|VBA練習問題(2月20日)
VBA100本ノック 91本目:時間計算(残業時間の月間合計)|VBA練習問題(2月19日)
VBA100本ノック 90本目:セルに重なっている画像の削除|VBA練習問題(2月17日)
VBA100本ノック 89本目:2つのフォルダの統合|VBA練習問題(2月16日)
VBA100本ノック 88本目:クロスABC分析作成|VBA練習問題(2月15日)
VBA100本ノック 87本目:数式のシート間の依存関係|VBA練習問題(2月13日)
VBA100本ノック 86本目:全シートの総当たり表を作成|VBA練習問題(2月12日)
VBA100本ノック 85本目:請求日から入金予定日を算出|VBA練習問題(2月10日)
VBA100本ノック 84本目:ブックの自動バックアップ|VBA練習問題(2月9日)


アクセスランキング ・・・ ランキング一覧を見る

1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.変数宣言のDimとデータ型|VBA入門
4.マクロって何?VBAって何?|VBA入門
5.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
6.繰り返し処理(For Next)|VBA入門
7.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
8.セルに文字を入れるとは(Range,Value)|VBA入門
9.とにかく書いてみよう(Sub,End Sub)|VBA入門
10.マクロはどこに書くの(VBEの起動)|VBA入門




このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。


記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。



このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
本文下部へ