Dictionaryのitemを効率よく配列に格納

Question

まだエクセル2000です。
A列に商品名（約1,000種類）
B列に分類名（10種類）
C列に売上高　がある表があります。
（実際はその他の欄もありますが、質問のため単純化しています）
1行1レコードで時系列順に記載されていますので商品名も分類名も重複しています。
（もちろんデータ自体は重複していません。）
行数は不定です。

このデータから、各商品ごとに各分類別の売上高一覧（同一商品名でも分類が違えば別に集計）を作成するため、Dictionaryオブジェクトを利用して以下のマクロを書きました、

Sub test01()
　　Dim myDic As Object
　　Dim myV, myW, myX
　　Dim i As Long, n As Long
　　Dim ws As Worksheet

With Sheets("Test01")
　　　　myV = .Range("A1", .Cells(Rows.Count, "C").End(xlUp)).Value '対象範囲を配列に
　　End With
 
　　ReDim myW(1 To UBound(myV), 1 To 3) '一覧データ格納用2次元配列サイズ設定
　　Set myDic = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(myV)
　　　　If Not myDic.Exists(myV(i, 1) & myV(i, 2)) Then '商品+分類が初出なら
　　　　　　myDic.Add myV(i, 1) & myV(i, 2), myV(i, 3) 'keyに追加、itemに売上
　　　　　　n = n + 1 'カウント
　　　　　　myW(n, 1) = myV(i, 1) '配列に商品名
　　　　　　myW(n, 2) = myV(i, 2) '配列に分類名
　　　　Else '商品+分類が既出なら
　　　　　　myDic(myV(i, 1) & myV(i, 2)) = myDic(myV(i, 1) & myV(i, 2)) + myV(i, 3) 'itemに売上加算
　　　　End If
　　Next i
　　ReDim myX(0 To UBound(myDic.Items)) 'item配列格納用1次元配列サイズ設定
　　myX = myDic.Items '1次元配列にItem格納
　　For i = 1 To UBound(myDic.Items) + 1
　　　　myW(i, 3) = myX(i - 1) '配列から配列へitemデータ複写
　　Next i
　　Set ws = Sheets.Add 'シート追加
　　ws.Range("A1").Resize(UBound(myDic.keys) + 1, 3).Value = myW '配列張り付け
　　Set myDic = Nothing
　　Set ws = Nothing
End Sub

これで正常かつ高速に作動するのですが、疑問点があります。
itemのデータを2次元配列、myWの3列目に格納するのに、いったん1次元配列myXを経由しなくともよい方法はないのかということです。
ここを変えてみても多分実行速度にほとんど影響はないとは思いますが、何か無駄なことをしているようで気になります。
itemを配列myWにとりこまず、直接ワークシートのC1以下にApplication.Transpose(myDic.items)で張るのが効率的と思いますが、わたしのエクセルがまだ2000のため、Transpose関数の限界、5461個にひっかかるおそれがあり、使えません。
どうかご教示ください。

end-u · Accepted Answer

A)ダイレクトにitemsをFor Eachで回すか
Dim d
i = 0
For Each d In dic.Items
　　i = i + 1
　　Debug.Print i, d
Next

B)ダイレクトにitemsをIndexで回すか
Dim i As Long
For i = 0 To dic.Count - 1
　　Debug.Print i + 1, dic.Items()(i)
Next

C)Transpose関数制限回避のFunctionを作っておくか
http://oshiete.goo.ne.jp/qa/5031943.html

D)そもそもitemに格納せずに最初から書き出し用配列で加算するか
Dim s As String
For i = 1 To UBound(myV)
　　s = myV(i, 1) & myV(i, 2)
　　If Not myDic.Exists(s) Then '商品+分類が初出なら
　　　　n = n + 1 'カウント（配列のIndex）
　　　　'（この時itemにはカウントアップした配列Indexを格納します）
　　　　myDic.Add s, n 'keyに追加、itemにIndex
　　　　myW(n, 1) = myV(i, 1) '配列に商品名
　　　　myW(n, 2) = myV(i, 2) '配列に分類名
　　　　myW(n, 3) = myV(i, 3) '配列に売上
　　Else '商品+分類が既出なら
　　　　myW(myDic(s), 3) = myW(myDic(s), 3) + myV(i, 3) '配列に売上加算
　　End If
Next i

..など。
今回、速度的なものは検証してません。
いろいろ試してみてください。

end-u · Answer

データ型に応じて、配列の型を適切に決める事が可能なら
もう少し改善できるかと思います。

Sub try()
　　Dim dic As Object 'Scripting.Dictionary
　　Dim s　 As String
　　Dim i　 As Long
　　Dim j　 As Long
　　Dim n　 As Long
　　Dim mx　As Long
　　Dim v　 As Variant
　　Dim w() As String
　　Dim x() As Long 'Double

With Sheets("Sheet1")
　　　　v = .Range("A1", .Cells(.Rows.Count, "C").End(xlUp)).Value
　　End With
　　mx = UBound(v)
　　ReDim w(1 To mx, 1 To 2)
　　ReDim x(1 To mx, 1 To 1)
　　Set dic = CreateObject("Scripting.Dictionary") 'New Dictionary
　　For i = 1 To mx
　　　　s = v(i, 1) & v(i, 2)
　　　　If Not dic.Exists(s) Then
　　　　　　n = n + 1
　　　　　　dic(s) = n
　　　　　　w(n, 1) = v(i, 1)
　　　　　　w(n, 2) = v(i, 2)
　　　　End If
　　　　j = dic(s)
　　　　x(j, 1) = x(j, 1) + v(i, 3)
　　Next
　　With Sheets.Add
　　　　.Range("A1:B1").Resize(n).Value = w
　　　　.Range("C1").Resize(n).Value = x
　　End With
　　
　　Erase w, x
　　Set dic = Nothing
End Sub

#当然、[Microsoft Scripting Runtime]を参照設定すればもっと速くなりますが。

Dictionaryのitemを効率よく配列に格納

A)ダイレクトにitemsをFor Eachで回すか

この回答への補足

データ型に応じて、配列の型を適切に決める事が可能なら

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング