マクロVBAで売上実績表を自動更新できるようにしたいです

マクロVBAについての質問です。
売上実績表を自動で更新できるようなコードを作成したいと思っています。
製品名、月、年度、定価売上、売上個数、ブランド、カテゴリー(大)、カテゴリー(小)を記入したrowデータを作成し、それを元にブランドのカテゴリー毎を年度や年月で分けた表を作成したいです。
クロス集計のように表作成をすればよいのかとも考えましたが、よくわからず困っています。
初心者故、どなたかコードを教えて頂けますと幸いです。
なお、実績表の累計や平均も自動で計算されるようにしたり、新製品が出た時などはブランドカテゴリーの中にきちんと認識されて更新時に組み込まれるように、また罫線もそれに合わせて動くようにしたいと思っています。
上記のようなことを叶えられるコードはありますでしょうか…？

宜しくお願い致します。

meg_

2020/05/11 03:08

ピボットテーブルでは実現不可能なことでしょうか？Excelの機能で事足りるのであればVBAより良いと思います。

ari818sa

2020/05/11 03:27

現在ピボットでやっているのですが、毎回更新するたびに累計や平均の範囲を変えたり、製品が増えることで表の照合させるのが面倒くさかったり…同時にグラフも作っているのですが、その更新もいちいち手間だったので、うまくVBAで一括更新できないかなと思い質問させて頂きました^^;

meg_

2020/05/11 03:45

VBAで作るなら一からコードを作成することになるかと思います。今現在質問者さんがどのぐらいVBAが書けるかによってはアドバイス出来ることもあるかもしれません。

行動規範の内容に同意します

回答1件

簡単な物で、こんな感じ参照になれば。
※罫線は別途です。ソートはしていません。

元データ

集計結果

VBA
1Sub tes01()
2  Dim Ws As Worksheet
3  Set Ws = ThisWorkbook.Worksheets(1) '("Sheet1")
4  Dim myDic As Object, myKey, myItem
5  Set myDic = CreateObject("Scripting.Dictionary")
6  
7  
8  Dim i As Long
9  Dim strMat
10  Dim iRow As Integer
11  Dim strHin1 As String
12  Dim strHin2 As String
13  Dim iPas As Boolean
14  Dim Ws2 As Worksheet
15
16  maxRow = Ws.Cells(Rows.Count, 1).End(xlUp).Row
17  maxRow_l = 1
18  For i = 3 To maxRow
19    strMat = Ws.Cells(i, 1).Value & "#$#" & Ws.Cells(i, 2).Value
20    If Not myDic.exists(strMat) Then
21      myDic.Add strMat, Ws.Cells(i, 3).Value
22    Else
23      myDic(strMat) = myDic(strMat) + Ws.Cells(i, 3).Value
24    End If
25  Next i
26  
27  Set Ws2 = ThisWorkbook.Worksheets(2)
28  Ws2.UsedRange.Clear
29  
30  myKey = myDic.Keys
31  myItem = myDic.items
32  iPas = False
33  iRow = 2
34  strHin2 = "" 'Left(myKey(0), (Len(myKey(0)) - InStr(myKey(0), "#$#")))
35  For i = 0 To myDic.Count - 1
36    strMat = Split(myKey(i), "#$#")
37    Ws2.Cells(i + 2, 3).Value = strMat(0)
38    Ws2.Cells(i + 2, 4).Value = strMat(1)
39    Ws2.Cells(i + 2, 5).Value = myItem(i)
40    strHin1 = strMat(0)
41    If strHin2 = strMat(0) Then
42      Ws2.Cells(i + 2, 3).Value = ""
43      iPas = True
44    Else
45      If iPas = True Then
46        Range(Ws2.Cells(iRow, 3), Ws2.Cells(i + 1, 3)).Merge
47      End If
48      strHin2 = strMat(0)
49      iRow = i + 2
50      iPas = False
51    End If
52  Next i
53  If iPas = True Then
54    Range(Ws2.Cells(iRow, 3), Ws2.Cells(i + 1, 3)).Merge
55  End If
56  Set myDic = Nothing
57  Ws2.Activate
58  Set Ws = Nothing
59  Set Ws2 = Nothing
60End Sub
61