冬物クリーニング最大49%OFFはコチラ

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

教えて!goo グレード

A 回答 (2件)

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さま、その後もテストを続けた結果、まったく異なる事実に気づきました。
お礼で、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

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

補足日時:2010/11/26 11:11
    • good
    • 0
この回答へのお礼

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

お礼日時:2010/11/26 10:04

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


もう少し改善できるかと思います。

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]を参照設定すればもっと速くなりますが。
    • good
    • 0
この回答へのお礼

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

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

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

お礼日時:2010/11/27 16:26

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

教えて!goo グレード

人気Q&Aランキング