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

質問

まだエクセル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個にひっかかるおそれがあり、使えません。
どうかご教示ください。

回答No.1

end-u · ベストアンサー

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://okwave.jp/qa/q5031943.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さま、いつもありがとうございます。
いろんな方法がありますね、自分の未熟さを痛感します。
(///▽///)

5万3千行の同一データで試しました。

1回目
test01(掲示したわたしのコード)　0.515625　
test02(最初から書き出し用配列で加算)　0.390625　
test03(itemsをFor Eachで回す)　0.515625
test04(itemsをIndexで回す)　0.546875
test05(Transpose回避Function)　0.53125　　

2回目
test01　0.53125
test02　0.390625
test03　0.53125
test04　0.53125
test05　0.53125

3回目
test01　0.515625
test02　0.375
test03　0.53125
test04　0.515625
test05　0.53125

という結果でした。
最初から書き出し用配列で加算がNo1で、あとは大差なしというところです。
せっかくDictionaryオブジェクトを使うんだからItemで加算と考えていましたが、最初から配列に加算させた方が圧倒的に高速ですね。
もっともコンマ以下の差ですから、あとはコードの可読性も考えなければいけないのでしょうが。
大変勉強になりました。
ありがとうございます。(o。_。)o

補足

end-uさま、その後もテストを続けた結果、まったく異なる事実に気づきました。
お礼で、test02(最初から書き出し用配列で加算)　が最速と書きましたが、test02とその他の記述の違いに気づきました。
test02では、s = myV(i, 1) & myV(i, 2)　と、商品名と分類をまとめて変数に代入したコードですが、他はmyV(i, 1) & myV(i, 2)　のまま使用しています。
ひょっとしてと思い、test01、test03～test05もすべてs = myV(i, 1) & myV(i, 2)　と、変数方式に変えて比較しました。

結果は以下の通り

test01(掲示したわたしのコード)　0.375
test02(最初から書き出し用配列で加算)　0.390625　
test03(itemsをFor Eachで回す)　0.375
test04(itemsをIndexで回す)　0.375
test05(Transpose回避Function)　0.390625

逆に、初から書き出し用配列で加算だけが変わりませんので、もっとも遅いという結果になりました！
変数に入れることでこんなに変わるなんて驚きです。
すっごく勉強になりました。

回答No.2

end-u

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

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]を参照設定すればもっと速くなりますが。

お礼

重ね重ねありがとうございます。

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

やってみました。
自宅なので昨日と同じデータでは試せないのですが、5万行のテストデータを作成して他のコードと比較をしてみたら、なんと半分の時間でした。
すごいですねえ。