エクセル2003(VBA)で複数条件の合計を出したい

質問

エクセル2003(VBA)で日別個人集計表を作っています。が
配列関数を使うとほぼ動かない量のデータがあり、ユーザー関数等
を作って処理すべきなのかなと思い、ご質問させて頂きました。
一括処理してくれるようなVBAを希望しております。
下記に具体的なデータを記載しますので、どうかお知恵をお貸し下さい。
よろしくお願い致します。

○元の参照データ(SheetA)　※レジのデータです
A1: (日時)　　　B2: (担当) C2: (売上額)
A2: 09/03/03 08:26 B2: 伊藤 C2: 1,000
A3: 09/03/04 18:12 B3: 武田 C2: 1,000
A4: 09/03/05 15:48 B4: 甲斐 C4: 1,000
A5: 09/03/05 09:24 B5: 迫田 C5: 1,000
A6: 09/03/04 03:23 B6: 武田 C6: 2,000
・
・
以下30000行ぐらいあります。

○日別個人集計表(SheetB)
A1: (日付)　　　B2: (担当) C2: (売上額)
A2: 09/03/03 B2: 伊藤 C2: 1,000　←下記参照
A3: 09/03/04 B3: 武田 C2: 3,000
A4: 09/03/05 B4: 甲斐 C4: 1,000
A5: 09/03/05 B5: 迫田 C5: 1,000

　※C列には現在配列関数を入れ、オートフィルしていますが30行(人)を超えるともう動きません
　　C列は現在、下記の通りです。
　　例){=SUMPRODUCT(TEXT(SheetA!$A$2:$A$65536,"yy/mm/dd")=A2)*
　　　　　(SheetA!$B$2:$B$65536=B2),SheetA!$C$2:$C$65536)}

回答No.1

mitarashi · ベストアンサー

条件に合いそうな、昔作ったコードがありましたので、日付対応だけしてみました。
（前提）
・データは最初のシートの、A,B,C列に存在し、Ctrl+Shift+:で目的のデータだけが選択できる様な配置であること。
・結果は二番目のシートに書き込む。見出し転写無し、事前消去等何もしていない。
30000行で動くかどうかは不明です。またXL2000用のコードです。2003対応、解説はできません。
Sub test()
Dim myDic As Object, myKey As Variant
Dim i As Long, j As Long
Dim keyString As String
Dim splitArray As Variant
Dim sourceArray As Variant
Dim destArray() As Variant
Dim destRange As Range

'配列に取り込む
sourceArray = Sheets(1).Range("A1").CurrentRegion
Set myDic = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(sourceArray, 1)
'およそ使いそうもない文字☆をデリミタに設定。もし使っているなら適当な文字に変更要。
keyString = Format(sourceArray(i, 1), "yyyy/mm/dd") & "☆" & sourceArray(i, 2)
If Not myDic.exists(keyString) Then
myDic.Add keyString, sourceArray(i, 3)
Else
myDic.Item(keyString) = myDic.Item(keyString) + sourceArray(i, 3)
End If
Next i
myKey = myDic.keys
'出力用配列に収納
ReDim destArray(1 To myDic.Count, 1 To 3)
For i = 1 To myDic.Count
splitArray = Split(myKey(i - 1), "☆")
destArray(i, 1) = DateValue(splitArray(0))
destArray(i, 2) = splitArray(1)
destArray(i, 3) = myDic(myKey(i - 1))
Next i
Set myDic = Nothing
'中味の確認用
For i = 1 To UBound(destArray, 1)
For j = 1 To 3
Debug.Print destArray(i, j)
Next j
Next i
'ワークシートへの貼り付け
Set destRange = Sheets(2).Range("a1").Resize(UBound(destArray, 1), 3)
destRange = destArray
End Sub

お礼

素早いご対応、心から感謝いたします。
条件の仮提案までもお心遣い重ねて感謝です。
目的の9割解決いたしました。!!
あとは多少のカスタマイズが必要になってきそうなので
ちょこちょこ改良して使用させて頂きます。
本当にありがとうございました。mm

回答No.2

n-jun

Sheet１からSheet２へ書き出しと言う事で。

Sub　try()
　Dim　myDic　As　Object
　Dim　st　As　String
　Dim　i　As　Long
　Dim　v,　w,　x,　mykey

　Set　myDic　=　CreateObject("Scripting.Dictionary")

　With　Worksheets("Sheet1")
　　　　　　v　=　.Range(.Range("A2"),　.Cells(Rows.Count,　1).End(xlUp)).Resize(,　3).Value
　End　With

　For　i　=　1　To　UBound(v,　1)
　　　　　w　=　Format(v(i,　1),　"yyyy/mm/dd")
　　　　　st　=　w　&　"_"　&　v(i,　2)
　　　　　If　Not　myDic.Exists(st)　Then
　　　　　　　　myDic(st)　=　Array(w,　v(i,　2),　Val(v(i,　3)))
　　　　　Else
　　　　　　　　myDic(st)　=　Array(w,　v(i,　2),　myDic(st)(2)　+　Val(v(i,　3)))
　　　　　End　If
　Next

　With　Worksheets("Sheet2")
　　　　　　.Range("A1:C1").Value　=　Worksheets("Sheet1").Range("A1:C1").Value
　　　　　　With　.Range("A2").Resize(myDic.Count)
　　　　　　　　　　　.Resize(,　3).Value　=　Application.Transpose(Application.Transpose(myDic.Items))
　　　　　　　　　　　.NumberFormatLocal　=　"yyyy/mm/dd"
　　　　　　End　With
　End　With
　Set　myDic　=　Nothing
　Erase　v
End　Sub

ご参考程度に。

お礼

秀逸なソースのご提供、感謝致します。
実行しました所、予想以上の処理速度で処理完了してしまいました。

私が理解(カスタマイズ)できればいつかソースを書き換えたいと思います。
ありがとうございました。