エクセルSUMIFS高速処理をVBAで処理したい

Question

エクセル関数のSUMIFSをVBAを使って高速処理したいです。

”抽出”シートと”集計”シートがあります。
”抽出”シートは下図のようになっています。

項目は「カテゴリ」、「部品」、「保管場所」、「推定在庫」、「実在庫」となっています。
処理結果は下図にようにしたいです。

「カテゴリ」は複数あります。違うカテゴリに同じ部品が入っている場合があります。
「カテゴリ」は5つくらいです。
「部品」は10万くらいあります。
SUMIFSを使うとかなり時間が掛かります。
「計」欄は数式(SUM)を残したいです。

以前教えていただいたコードは配列(Dictionary)を使うものでした。
在庫の種類が1種類であれば、可能なのですが、2種類になると分からなくなってしまいました。
コードを教えて下さい。

以前のコード
「集計」シートに縦軸に部品、横軸にカテゴリ、中の数字が足し算した結果が表示されています。

Public Sub サンプル()

   Dim dic As Object, dicE As Object
   Dim vA As Variant, vK As Variant, v As Variant
   Dim i As Long, j As Long, k As Long
   Dim LINE As Integer
   
   Set dic = CreateObject("Scripting.Dictionary")
   Set dicE = CreateObject("Scripting.Dictionary")

   With Worksheets("抽出")
      With .Range("A1", .Cells(Rows.Count, "A").End(xlUp))
         vA = .Resize(, 4).Value
      End With
   End With
   For i = 2 To UBound(vA)
      If (Not dic.Exists(vA(i, 2))) Then
         dic.Add vA(i, 2), CreateObject("Scripting.Dictionary")
      End If
      dic(vA(i, 2))(vA(i, 1)) = dic(vA(i, 2))(vA(i, 1)) + vA(i, 4)
      dicE(vA(i, 1)) = Empty
   Next

   ReDim vA(1 To dic.Count + 5, 1 To dicE.Count + 1)
   v = mySort(dicE.Keys)
   For i = 0 To UBound(v)
      j = i + 2
      vA(1, j) = v(i)
      dicE(v(i)) = j
      If (j > 2) Then
         vA(3, j) = vA(3, j - 1)
         vA(4, j) = vA(4, j - 1)
      End If
   Next
   i = 6
   For Each vK In mySort(dic.Keys)
      vA(i, 1) = vK
      For Each v In dic(vK).Keys
         vA(i, dicE(v)) = dic(vK)(v)
      Next
      i = i + 1
   Next

   Application.ScreenUpdating = False
   With Worksheets("集計")
      .Cells.Delete
      With .Range("A1").Resize(UBound(vA), UBound(vA, 2))
         .Value = vA
      End With
      .Activate
   End With

    Range("A1") = "カテゴリ"
    Range("B1") = "部品"

   Application.ScreenUpdating = True

   Set dic = Nothing
   Set dicE = Nothing
   MsgBox "終了しました"


End Sub

Private Function mySort(ByVal vA As Variant) As Variant
   Dim v As Variant
   Dim i As Long, j As Long

   For i = LBound(vA) To UBound(vA) - 1
      For j = i + 1 To UBound(vA)
         If (vA(i) > vA(j)) Then
            v = vA(i)
            vA(i) = vA(j)
            vA(j) = v
         End If
      Next
   Next
   mySort = vA
End Function

例ではカテゴリが2つですが、4個の場合は下図のようにしたいです。

集計する時、保管場所は無視して足し算します。

Comments

[tatsu99]

カテゴリが５つくらいとのことですが、
カテC、カテD、カテEがあった場合、レイアウトはどのようにしたいのでしょうか？

[cd987456]

質問欄を更新してレイアウトを追記しました。

[sazi]

> SUMIFSを使うとかなり時間が掛かります。
現状どの程度の時間が掛かっていて、目標はどの位なんでしょう？

[cd987456]

処理する毎に部品の数が違うのですが、今回の場合は抽出シートが約11万行で、集計シートの部品は約4万でした。カテゴリは2つでした。処理は約10分～15分くらいでした。
可能であれば、1分～2分くらいにしたいです。

[otn]

ピボットを使えばよい気がしますが。

Answer 1

以下のようにしてください。
集計シートの２行目の見出しはマクロで設定します。
集計シートの１行目の見出しはマクロで設定しません。（手作業で設定しておいてください）
A列は部品でソート、2行目はカテゴリでソートしています。
（あなたが提示されたソート処理をそのまま使っています）

Option Explicit


Public Sub 集計()
    Dim dicCA As Object 'カテゴリ　                 キー：カテゴリ　値：true
    Dim dicP1 As Object '部品単位在庫　             キー：部品　値：推定合計
    Dim dicPC1 As Object '部品・カテゴリ単位在庫    キー：部品＋カテゴリ　値：推定合計
    Dim dicP2 As Object '部品単位在庫　             キー：部品　値：実在庫合計
    Dim dicPC2 As Object '部品・カテゴリ単位在庫    キー：部品＋カテゴリ　値：実在庫合計
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim maxrow1 As Long
    Dim row1 As Long
    Dim row2 As Long
    Dim key1 As Variant
    Dim key2 As Variant
    Dim key3 As Variant
    Dim cate As Variant     'ソート済みカテゴリ配列
    Dim parts As Variant    'ソート済み部品配列
    Dim i
    Set sh1 = Worksheets("抽出")
    Set sh2 = Worksheets("集計")
    Set dicCA = CreateObject("Scripting.Dictionary") ' 連想配列の定義
    Set dicP1 = CreateObject("Scripting.Dictionary") ' 連想配列の定義
    Set dicPC1 = CreateObject("Scripting.Dictionary") ' 連想配列の定義
    Set dicP2 = CreateObject("Scripting.Dictionary") ' 連想配列の定義
    Set dicPC2 = CreateObject("Scripting.Dictionary") ' 連想配列の定義
    maxrow1 = sh1.Cells(Rows.Count, 1).End(xlUp).row 'sheet1 最終行を求める
    Application.ScreenUpdating = False

    For row1 = 2 To maxrow1
        'カテゴリ
        key1 = sh1.Cells(row1, "A").Value
        If dicCA.exists(key1) = False Then
            dicCA(key1) = True
        End If
        '部品
        key2 = sh1.Cells(row1, "B").Value
        If dicP1.exists(key2) = False Then
            dicP1(key2) = sh1.Cells(row1, "D").Value    '推定在庫設定
            dicP2(key2) = sh1.Cells(row1, "E").Value    '実在庫設定
        Else
            dicP1(key2) = dicP1(key2) + sh1.Cells(row1, "D").Value   '推定在庫加算
            dicP2(key2) = dicP2(key2) + sh1.Cells(row1, "E").Value   '実在庫加算
        End If
        '部品＋カテゴリ
        key3 = sh1.Cells(row1, "B").Value & "|" & sh1.Cells(row1, "A").Value
        If dicPC1.exists(key3) = False Then
            dicPC1(key3) = sh1.Cells(row1, "D").Value    '推定在庫設定
            dicPC2(key3) = sh1.Cells(row1, "E").Value    '実在庫設定
        Else
            dicPC1(key3) = dicPC1(key3) + sh1.Cells(row1, "D").Value   '推定在庫加算
            dicPC2(key3) = dicPC2(key3) + sh1.Cells(row1, "E").Value   '実在庫加算
        End If
    Next
    
    'カテゴリソート
    cate = mySort(dicCA.keys)
    '部品ソート
    parts = mySort(dicP1.keys)
    '集計シートの２行目以降をクリア
    sh2.Rows("2:" & Rows.Count).ClearContents
    '集計シートの見出し設定
    For i = 0 To UBound(cate)
        sh2.Cells(2, 2 + i).Value = cate(i)
        sh2.Cells(2, 4 + UBound(cate) + i).Value = cate(i)
    Next
    sh2.Cells(2, 2 + UBound(cate) + 1).Value = "合計"
    sh2.Cells(2, 4 + 2 * UBound(cate) + 1).Value = "合計"
    
    '部品数繰り返す
    For i = 0 To UBound(parts)
        row2 = i + 3
        sh2.Cells(row2, "A").Value = parts(i)   '部品
        Call output(sh2, parts(i), row2, cate, 2, dicPC1, dicP1) '推定在庫設定
        Call output(sh2, parts(i), row2, cate, UBound(cate) + 4, dicPC2, dicP2) '実在庫設定
    Next
    Application.ScreenUpdating = True
    MsgBox ("完了")
End Sub

Private Sub output(ByVal sh2 As Worksheet, ByVal part As String, ByVal row2 As Long, ByVal cate As Variant, ByVal scol As Long, ByVal dicPC As Object, ByVal dicP As Object)
    Dim i As Long
    Dim col2 As Long
    Dim key3 As Variant
    For i = 0 To UBound(cate)
        col2 = scol + i
        key3 = part & "|" & cate(i)
        If dicPC.exists(key3) = True Then
            sh2.Cells(row2, col2).Value = dicPC(key3)
        Else
            sh2.Cells(row2, col2).Value = 0
        End If
    Next
    sh2.Cells(row2, scol + UBound(cate) + 1).Value = dicP(part)
End Sub

Private Function mySort(ByVal vA As Variant) As Variant
   Dim v As Variant
   Dim i As Long, j As Long

   For i = LBound(vA) To UBound(vA) - 1
      For j = i + 1 To UBound(vA)
         If (vA(i) > vA(j)) Then
            v = vA(i)
            vA(i) = vA(j)
            vA(j) = v
         End If
      Next
   Next
   mySort = vA
End Function

Comments

[cd987456]

ありがとうございます。すごいです。丁寧なコメントもありがとうございます。
今日は部品が3万くらいでした。処理が30秒くらい。すごく助かりました。