vbaのDictionaryオブジェクト　演算子を使った複数条件の集計

前提・実現したいこと

Excel vba のDictionaryを用い、複数条件の集計をしたいのですが、どの様に出力をしたら良いのか解りません。

　　　【売上シート】　10000行程
・　　　C列　　I列　　　E列　　　S列
1行目　部門　　日付　科目コード　金額

　　
【集計結果シート】
・　　　　　　D列　　　　　　　　　　G列　　　　　H列　　　　　I列　
2行目　　　　　　　　　　　　　　　集計開始年　　　　月　　　　　日
3行目　　　　　　　　　　　　　　　集計終了年　　　　月　　　　　日
5行目　　　　　　　　　集計開始部門　1001
6行目　　　　　　　　　集計終了部門　3001
7行目　　科目コード　　集計除外部門　2001
8行目　　　500　　　　　　　　　　　金額出力
9行目　　　501　　　　　　　　　　　金額出力

上記2つの【売上シート】【集計結果シート】売上シートのデータを集計結果シートへ集計します。

ifで売上シートのデータが集計対象内であればDictionary登録。
科目Dicにて集計結果シートのD列の科目コードを作成し、書き出し（省略していますが、科目名をB~E列に分割して書きだしています）
集計Dicに【キー】部門+科目コード　、【アイテム】金額　金額出力用を作成。

集計結果シートへ科目の書き出しを行った後、集計開始部門（一つの条件）と科目コードに対する金額の出力まではできました。

教えて頂きたいこと
更に集計開始部門、集計終了部門、集計除外部門の3つを条件とした金額を集計したいのですが、どの様なコードにしたら良いのか解りません。
例えば、上記の例だと、1001~3001の部門間の、2001は除いた金額を出力したいです。
どなたか教えて頂けないでしょうか。

集計結果シートの部門は横に100列程、科目コードは下に80行程あります。

該当のソースコード

Sub 科目作成書き出し後集計()
'【Dictionaryを使い科目Dicは科目書き出し用、集計Dicは集計用】


Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets("売上")
Set ws3 = Worksheets("集計結果")


'集計開始日と集計終了日を設定
Dim day1 As Date, day2 As Date, day3 As Date
day1 = ws3.Cells(2, 7).Value & "/" & ws3.Cells(2, 8).Value & "/" & ws3.Cells(2, 9).Value
day2 = ws3.Cells(3, 7).Value & "/" & ws3.Cells(3, 8).Value & "/" & ws3.Cells(3, 9).Value


'連想配列の定義
Dim 科目Dic As Object, 集計Dic As Object
Set 科目Dic = CreateObject("Scripting.Dictionary")
Set 集計Dic = CreateObject("Scripting.Dictionary")

'最終行を取得
Dim maxRow1 As Long, maxRow2 As Long, maxRow3 As Long
maxRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
maxRow3 = ws3.Cells(Rows.Count, 2).End(xlUp).Row

'最終列を取得
Dim maxCol3 As Long
maxCol3 = ws3.Cells(5, Columns.Count).End(xlToLeft).Column


'売上シートを配列へ格納
Dim 売上data As Variant
売上data = ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxRow1, 20)).Value
経費data = ws2.Range(ws2.Cells(2, 1), ws2.Cells(maxRow2, 20)).Value


'■集計前に集計結果シートクリア
ws3.Range(ws3.Cells(8, 2), ws3.Cells(maxRow3 + 1, maxCol3)).Cells.Clear

'■画面更新停止
Application.ScreenUpdating = False


'■■売上シートの科目Dic、集計Dic作成
Dim i As Long, s As Long
Dim 科目key As Variant, 科目Item As Long, 集計key As Variant, 集計Item As Long


For i = LBound(売上data, 1) To UBound(売上data, 1)
  
  day3 = 売上data(i, 9)
     
    '■集計対象日内の場合
     If day3 >= day1 And day3 <= day2 Then
     
      '■売上シート科目Dic作成
        科目key = 売上data(i, 1) & "-" & 売上data(i, 2) & "-" & 売上data(i, 5) & "-" & 売上data(i, 6)
        科目Item = 売上data(i, 19)
      
        If Not 科目key = "---" Then
            If Not 科目Dic.Exists(科目key) Then
              科目Dic.Add 科目key, 科目Item
            Else
              科目Dic(科目key) = 科目Dic(科目key) + 科目Item
            End If
        End If
        
      '■売上シート集計Dic作成
        集計key = 売上data(i, 3) & "-" & 売上data(i, 5)
        集計Item = 売上data(i, 19)

        If Not 集計key = "-" Then
            If Not 集計Dic.Exists(集計key) Then
              集計Dic.Add 集計key, 集計Item
            Else
              集計Dic(集計key) = 集計Dic(集計key) + 集計Item
            End If
        End If
        
     End If
     
Next i
     
     
   
'■科目Dicを配列格納、書き出し
Dim ary1 As Variant,  ary3 As Variant, ary4 As Variant
ary1 = 科目Dic.Keys
ReDim ary3(UBound(ary1), 3)

For i = 0 To UBound(ary1)
   ary4 = Split(ary1(i), "-")
   
    ary3(i, 0) = ary4(0)
    ary3(i, 1) = ary4(1)
    ary3(i, 2) = ary4(2)
    ary3(i, 3) = ary4(3)
Next i
ws3.Range(ws3.Cells(8, 2), ws3.Cells(科目Dic.Count + 7, 5)) = ary3


'■集計Dicを配列格納、書き出し

'科目を書き出し後､最終行を再取得
Dim maxRow4 As Long
maxRow4 = ws3.Cells(Rows.Count, 2).End(xlUp).Row

Dim ary5 As Variant, ary6 As Variant, 科目コードary As Variant, 部門コードary As Variant, 集計結果ary As Variant
Dim 条件Key As String
ary5 = 集計Dic.Keys
ary6 = 集計Dic.Items
ReDim 集計結果ary(UBound(ary5) + 1, maxCol3 - 6)

'部門コードと科目コードを配列へ格納
科目コードary = ws3.Range(ws3.Cells(8, 4), ws3.Cells(maxRow4, 4))
部門コードary = ws3.Range(ws3.Cells(5, 7), ws3.Cells(7, maxCol3))


For s = 1 To UBound(部門コードary, 2)
   For i = 1 To UBound(科目コードary, 1)

      集計結果ary(i - 1, s - 1) = 集計Dic(部門コードary(1, s) & "-" & 科目コードary(i, 1))

   Next i

Next s


ws3.Range(ws3.Cells(8, 7), ws3.Cells(UBound(ary5) + 1, maxCol3)) = 集計結果ary






'■開放■
 Set 科目Dic = Nothing
 
'■画面更新開始
Application.ScreenUpdating = True
     
End Sub

試したこと

上記のコードは集計開始の1つの部門コードまでは正しい金額が出力できたところです。
条件を3つにする場合、どの様なコードにしたら良いのか考えても調べても検討がつかないため、教えて頂きたいです。
拙い説明と解りにくいコードの点、ご容赦ください。

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

回答1件

ベストアンサー

キーを分解して値を比較してを繰り返せばできるんじゃないでしょうか。

VBA
1Dim lower As Long, upper As Long, exclusion As Long
2Dim col As Long, row As Long
3Dim 部門 As Long, 科目 As Long, target As Long
4Dim total As Long
5Dim key As Variant
6
7ReDim 集計結果ary(1 To UBound(科目コードary, 1), 1 To UBound(部門コードary, 2))
8
9For col = 1 To UBound(部門コードary, 2)
10    lower = 部門コードary(1, col)
11    upper = 部門コードary(2, col)
12    exclusion = 部門コードary(3, col)
13    
14    For row = 1 To UBound(科目コードary, 1)
15        target = 科目コードary(row, 1)
16        total = 0
17        
18        For Each key In ary5
19            部門 = Split(key, "-")(0)
20            科目 = Split(key, "-")(1)
21            If 部門 >= lower And 部門 <= upper And 部門 <> exclusion And 科目 = target Then
22                total = total + 集計Dic(key)
23            End If
24        Next
25            
26        集計結果ary(row, col) = total
27    Next
28Next
29
30ws3.Range(ws3.Cells(8, 7), ws3.Cells(maxRow4, maxCol3)) = 集計結果ary

投稿2021/06/22 16:00

neconekocat

総合スコア443

umebosi

2021/06/22 17:35

早速ご回答頂き、ありがとうございます！ずっとどうしたら出来るのか考えていたことが頂いたコードでできました。又、Dictionaryにない金額は空欄になっていたのが、neconekocatさんのコードだと0が入った点も、同時にしたかった事が解決できました。集計結果aryのReDim の方法もなるほど、こうしたらスッキリするのかと。 For Eachも理解できていないため、きちんとかみ砕いて理解していきます。早く完成させたかったので助かりました。ありがとうございます。