■DictionaryのItemに配列を

Dicへの複数item追加 - 教えて！goo

題材としてちょっと興味があったので書込みしました。
でもやっぱりItemに配列をセットするより『集計＆転記用の配列を別に用意』したほうが
簡単で速度も多少は速いような気がするんですよね。
...という事でメモ代わりに再掲。

Sub try1()
　　Const DLM = "|"
　　Dim dic As Object
　　Dim ws　As Worksheet
　　Dim s　 As String
　　Dim i　 As Long
　　Dim j　 As Long
　　Dim n　 As Long
　　Dim ary, tmp, c, k, v, w, x

　　ary = VBA.Array(3, 4) '集計列
　　With ThisWorkbook
　　　　v = .Sheets("元").Range("A1").CurrentRegion '.Resize(, 5)
　　　　Set ws = .Sheets("集計")
　　End With

　　Set dic = CreateObject("Scripting.Dictionary")
　　For i = 2 To UBound(v)
　　　　s = v(i, 1) & DLM & v(i, 2) & DLM & v(i, 5)
　　　　If Len(s) > 2 Then
　　　　　　If dic.Exists(s) Then
　　　　　　　　tmp = dic(s)
　　　　　　Else
　　　　　　　　ReDim tmp(0 To UBound(ary))
　　　　　　End If
　　　　　　j = 0
　　　　　　For Each c In ary
　　　　　　　　tmp(j) = tmp(j) + v(i, c)
　　　　　　　　j = j + 1
　　　　　　Next
　　　　　　dic(s) = tmp
　　　　End If
　　Next

　　n = dic.Count
　　ReDim w(1 To n)
　　i = 1
　　For Each k In dic.Keys
　　　　w(i) = Split(k, DLM)
　　　　i = i + 1
　　Next
　　With Application
　　　　w = .Transpose(.Transpose(w))
　　　　x = .Transpose(.Transpose(dic.Items))
　　End With

　　ws.UsedRange.ClearContents
　　With ws.Range("A1")
　　　　.Resize(, 5) = Array(v(1, 1), v(1, 2), v(1, 5), v(1, 3), v(1, 4))
　　　　.Offset(1).Resize(n, UBound(w, 2)).value = w
　　　　.Offset(1, UBound(w, 2)).Resize(n, UBound(x, 2)).value = x
　　　　.CurrentRegion.Sort Key1:=.Range("A2"), Order1:=xlAscending, _
　　　　　　　　　　　　　　Key2:=.Range("B2"), Order2:=xlAscending, _
　　　　　　　　　　　　　　Key3:=.Range("C2"), Order3:=xlAscending, _
　　　　　　　　　　　　　　Header:=xlYes
　　End With

　　Set dic = Nothing
　　Set ws = Nothing
End Sub

Sub try2()
　　Const DLM = "|"
　　Dim dic As Object
　　Dim ws　As Worksheet
　　Dim s　 As String
　　Dim i　 As Long
　　Dim j　 As Long
　　Dim k　 As Long
　　Dim n　 As Long
　　Dim key, ary, c, v, w

　　key = VBA.Array(1, 2, 5) 'key列
　　ary = VBA.Array(3, 4)　　'集計列
　　With ThisWorkbook
　　　　v = .Sheets("元").Range("A1").CurrentRegion '.Resize(, 5)
　　　　Set ws = .Sheets("集計")
　　End With
　　ReDim w(1 To UBound(v, 1), 1 To UBound(v, 2))

　　Set dic = CreateObject("Scripting.Dictionary")
　　n = 0
　　For i = 1 To UBound(v)
　　　　s = v(i, 1) & DLM & v(i, 2) & DLM & v(i, 5)
　　　　If Len(s) > 2 Then
　　　　　　If dic.Exists(s) Then
　　　　　　　　j = dic(s)
　　　　　　Else
　　　　　　　　n = n + 1
　　　　　　　　dic(s) = n
　　　　　　　　j = n
　　　　　　　　k = 1
　　　　　　　　For Each c In key
　　　　　　　　　　w(j, k) = v(i, c)
　　　　　　　　　　k = k + 1
　　　　　　　　Next
　　　　　　End If
　　　　　　k = 4
　　　　　　For Each c In ary
　　　　　　　　w(j, k) = w(j, k) + v(i, c)
　　　　　　　　k = k + 1
　　　　　　Next
　　　　End If
　　Next

　　ws.UsedRange.ClearContents
　　With ws.Range("A1")
　　　　.Resize(n, 5).value = w
　　　　.CurrentRegion.Sort Key1:=.Range("A2"), Order1:=xlAscending, _
　　　　　　　　　　　　　　Key2:=.Range("B2"), Order2:=xlAscending, _
　　　　　　　　　　　　　　Key3:=.Range("C2"), Order3:=xlAscending, _
　　　　　　　　　　　　　　Header:=xlYes
　　End With

　　Set dic = Nothing
　　Set ws = Nothing
End Sub

#Pivotのコードも結構速いんですけどね。データにもよるかな...