途中まで出来ているのですが‥(Dicへの複数item追加?)

質問

A　　　B　　　C　　　D　　　E　　　　←シート元
1　大区分　中区分　金額1　金額2　小区分　　←見出し行です。
2　　A社　管理課　12000　　3000　 1
3　　B社　総務課　10000　　2000　 1
4　　C社　業務課　 800 1000 　　 3
5　　A社　総務課　　　　　　　　　　　5
6　　C社　製造課　 600 5000　　　　2
7　　A社　製造課　15000 　　　　　　　1
8　　A社　管理課　 300 　　　　　　1
9　　B社　管理課　 800 2000　　　　　4
10　 D社　総務課　90000 9000　　　　　1
を大区分　中区分　小区分をKeyにして3要素が同じものをまとめて並び替えて集計するのですが（下記のように　金額1　金額2ごとに足し算）
　　　A　　　B　　　C　　　D　　　E　　　　←シート集計
1　大区分　中区分　小区分金額1　金額2　　　←見出し位置変更
2　　A社　管理課　　1 12000 3300
3　　A社　総務課　　5　　
4　　A社　製造課　　1 15000　　
5　　B社　総務課　　1 10000 2000
6　　B社　管理課　　4 8000 2000
以下省略
実際に作りたいものは、元シートの金額の項目が多いのです（列が飛び飛びに40位あります）今回の例でいえばCとDが　CからF　HからV　ABからCHとなりそれぞれ金額3,4,5～50みたいになってます。私なりに下記のコードのように進めてますが、表題のようにDictionaryに複数のitemを追加する方法が解らないため、金額の項目ごとに算出を繰り返すという効率が悪い方法をとってます。どなたかご教示頂けると幸いです。

Sub 3keyと2要素()
’実際は40要素くらいある
Dim OLDBOOK As Workbook
Dim SH1 As Worksheet
Dim SH2 As Worksheet
Dim myDic As Object, myKey, myItem
Dim myVal, myVal2, myVal3, myVal4, myVal5
Dim i As Long
Set OLDBOOK = ThisWorkbook
Set SH1 = OLDBOOK.Worksheets("元")
Set SH2 = OLDBOOK.Worksheets("集計")
SH2.Cells.ClearContents
SH2.Range("A1:B1").Value = SH1.Range("A1:B1").Value
SH2.Range("C1").Value = SH1.Range("E1").Value
SH2.Range("D1:E1").Value = SH1.Range("C1:D1").Value
Set myDic = CreateObject("Scripting.Dictionary")
SH1.Select
myVal = SH1.Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 5).Value
For i = 1 To UBound(myVal, 1)
myVal2 = myVal(i, 1) & "_" & myVal(i, 2) & "_" & myVal(i, 5)
If Not myVal2 = "_" & "_" Then
If Not myDic.exists(myVal2) Then
myDic.Add myVal2, myVal(i, 3)
Else
myDic(myVal2) = myDic(myVal2) + myVal(i, 3)
End If
End If
Next
myKey = myDic.keys ' 書き出し　とりあえず2要素
　　myItem = myDic.items
For i = 0 To UBound(myKey)
myVal3 = Split(myKey(i), "_")
SH2.Cells(i + 2, 1).Value = myVal3(0)
SH2.Cells(i + 2, 2).Value = myVal3(1)
SH2.Cells(i + 2, 3).Value = myVal3(2)
SH2.Cells(i + 2, 4).Value = myItem(i)
Next
Set myDic = Nothing
'********
Set myDic = CreateObject("Scripting.Dictionary")
myVal = SH1.Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 5).Value
For i = 1 To UBound(myVal, 1)
myVal2 = myVal(i, 1) & "_" & myVal(i, 2) & "_" & myVal(i, 5)
If Not myVal2 = "_" & "_" Then
If Not myDic.exists(myVal2) Then
myDic.Add myVal2, myVal(i, 4)
Else
myDic(myVal2) = myDic(myVal2) + myVal(i, 4)
End If
End If
Next
myKey = myDic.keys
myItem = myDic.items
For i = 0 To UBound(myKey)
myVal3 = Split(myKey(i), "_")
SH2.Cells(i + 2, 5).Value = myItem(i)
Next
Set myDic = Nothing
' 以下繰り返しするしかなく困ってます
SH2.Select
SH2.Range("A2", Range("E" & Rows.Count).End(xlUp)).Sort _
Key1:=Range("AF2"), Order1:=xlAscending, _
Key2:=Range("B"), Order2:=xlAscending, _
Key3:=Range("C2"), Order3:=xlAscending, _
Header:=xlGuess
Set OLDBOOK = Nothing
Set SH1 = Nothing
Set SH2 = Nothing
End Sub

回答No.4

end-u · ベストアンサー

>これを元に範囲指定をCurrentRegionではなく飛び飛びの列対応に広げれば、対応できると思います。
念のため。
Pivotの範囲指定は飛び飛びではできませんから、
全体を範囲指定して、集計したい項目をデータフィールドに追加するような対応になります。

>（飛び飛びの複数列といいましても列は固定です。）Keyにitemとして
>Cells（,）と Cells（,）とCells（,）と沢山付ける記述のしかた、
>そして加算してゆく方法、
>そして切り離し転記する方法を覚えたいのです。
飛び飛びの複数列対応は
ary = VBA.Array(3, 4) '集計列
などとして集計列を指定した ary をLoopさせれば良いです。
一応、転記をまとめて行う例も含め、サンプルとして提示しておきます。

Option Explicit

Sub try2()
　　Dim OLDBOOK As Workbook
　　Dim SH1　　 As Worksheet
　　Dim SH2　　 As Worksheet
　　Dim myDic　 As Object
　　Dim i　　　 As Long
　　Dim j　　　 As Long
　　Dim n　　　 As Long
　　Dim myVal, myVal2, ary, tmp, v, w, x, key

　　ary = VBA.Array(3, 4)　　'集計列

　　Set OLDBOOK = ThisWorkbook
　　Set SH1 = OLDBOOK.Worksheets("元")
　　Set SH2 = OLDBOOK.Worksheets("集計")
　　SH2.Cells.ClearContents
　　SH2.Range("A1:B1").Value = SH1.Range("A1:B1").Value
　　SH2.Range("C1").Value = SH1.Range("E1").Value
　　SH2.Range("D1:E1").Value = SH1.Range("C1:D1").Value
　　myVal = SH1.Range("E2", SH1.Range("A" & SH1.Rows.Count).End(xlUp)).Value

　　Set myDic = CreateObject("Scripting.Dictionary")

　　For i = 1 To UBound(myVal, 1)
　　　　myVal2 = myVal(i, 1) & "_" & myVal(i, 2) & "_" & myVal(i, 5)
　　　　If Not myVal2 = "_" & "_" Then
　　　　　　If myDic.exists(myVal2) Then
　　　　　　　　tmp = myDic(myVal2)
　　　　　　Else
　　　　　　　　ReDim tmp(0 To UBound(ary))
　　　　　　End If
　　　　　　j = 0
　　　　　　For Each v In ary
　　　　　　　　tmp(j) = tmp(j) + myVal(i, v)
　　　　　　　　j = j + 1
　　　　　　Next
　　　　　　myDic(myVal2) = tmp
　　　　End If
　　Next

　　n = myDic.Count
　　ReDim w(0 To n - 1)
　　i = 0
　　For Each key In myDic.keys
　　　　w(i) = Split(key, "_")
　　　　i = i + 1
　　Next
　　With Application
　　　　w = .Transpose(.Transpose(w))
　　　　x = .Transpose(.Transpose(myDic.items))
　　End With
　　SH2.Cells(2, 1).Resize(n, UBound(w, 2)).Value = w
　　SH2.Cells(2, 4).Resize(n, UBound(x, 2)).Value = x
　　Set myDic = Nothing

　　SH2.Range("E2", SH2.Range("A" & SH2.Rows.Count).End(xlUp)).Sort _
　　　　Key1:=SH2.Range("A2"), Order1:=xlAscending, _
　　　　Key2:=SH2.Range("B2"), Order2:=xlAscending, _
　　　　Key3:=SH2.Range("C2"), Order3:=xlAscending, _
　　　　Header:=xlNo

　　Set OLDBOOK = Nothing
　　Set SH1 = Nothing
　　Set SH2 = Nothing
End Sub

お礼

有難うございます。これで思ったものが出来そうです。
ary = VBA.Array(3, 4,○、○)　
myVal = SH1.Range("○2", SH1.Range("A" & SH1.Rows.Count).End(xlUp)).Value
SH2.Range("○2", SH2.Range("A" & SH2.Rows.Count).End(xlUp)).Sort
これらの○を変更するだけというのは後々の修正に対してもとても楽で感激です。私の今の技量ではこれで出来上がった一覧を経由して次の過程に進むのが無難であり確実な気がします。大変勉強になりました。しばらく眺め確実にものにしてゆきたいと思います。有難うございました。

回答No.3

redfox63

私なら 必要な項目を 別シートにコピー
転記先の題目を欲しい結果順に並べる
データ > フィルター > フィルターのオプション
で該当部分の重複の無い分類を抽出
金額1、金額2の部分には SUMPRODUCTで数式を設置
出来上がった範囲をコピーして 形式を選択して貼り付け > 値
といった手順でやるかも ・・・

コレクションオブジェクトの場合
Sub m2()
　　Dim r As Range, n As Integer
　　Dim col As New Collection
　　Dim sKey As String, value As Variant
　　Dim m() As String
　　Set r = Range("A1").CurrentRegion.Offset(1)
　　Set r = r.Resize(r.Rows.Count - 1)
　　For n = 1 To r.Rows.Count
　　　　sKey = Join(Array(r.Cells(n, 1), r.Cells(n, 2), r.Cells(n, 5)), ",")
　　　　'Debug.Print sKey
　　　　On Error Resume Next
　　　　　　value = col(sKey)
　　　　　　col.Remove sKey
　　　　　　If value <> "" Then
　　　　　　　　value = Left(value, InStr(value, " "))
　　　　　　　　m = Split(value, ",")
　　　　　　Else
　　　　　　　　ReDim m(1)
　　　　　　End If
　　　　On Error GoTo 0
　　　　m(0) = Val(m(0)) + Val(r.Cells(n, 3))
　　　　m(1) = Val(m(1)) + Val(r.Cells(n, 4))
　　　　Dim ss As String
　　　　ss = Join(m, ",") & " " & sKey
　　　　col.Add ss, sKey
　　Next

　　' Sheet2を適切なオブジェクトに修正してください
　　Set r = Sheet2.Range("A2")
　　Dim ss1() As String, dd() As Double, ar0, ar1
　　For n = 1 To col.Count
　　　　'Debug.Print n, col.Item(n)
　　　　ar0 = Split(col.Item(n), " ")
　　　　ss1 = Split(ar0(1), ",")
　　　　r.Resize(1, UBound(ss1) + 1).value = ss1
　　　　ar1 = Split(ar0(0), ",")
　　　　ReDim dd(UBound(ar1))
　　　　dd(0) = Val(ar1(0))
　　　　dd(1) = Val(ar1(1))
　　　　r.Resize(1, UBound(dd) + 1).Offset(0, UBound(ss1) + 1).value = dd
　　　　Set r = r.Offset(1)
　　Next
End Sub

Dictionaryの場合
Sub m3()
　　Dim r As Range, rngKey(2) As Range, rngDat(1) As Range
　　Dim n As Integer, m As Integer
　　Dim arS As Variant, arD As Variant
　　Dim dic As New Dictionary, sKey As String, sDat As String
　　Dim arKey() As String, arDat() As String

　　Set r = Range("A1").CurrentRegion.Offset(1)
　　Set r = r.Resize(r.Rows.Count - 1)
　　Set rngKey(0) = Intersect(r, Range("A:A"))
　　Set rngKey(1) = Intersect(r, Range("B:B"))
　　Set rngKey(2) = Intersect(r, Range("E:E"))
　　Set rngDat(0) = Intersect(r, Range("C:C"))
　　Set rngDat(1) = Intersect(r, Range("D:D"))

　　For n = 1 To rngKey(0).Rows.Count
　　　　ReDim arKey(2), arDat(1)
　　　　arKey(0) = rngKey(0).Cells(n, 1).value
　　　　arKey(1) = rngKey(1).Cells(n, 1).value
　　　　arKey(2) = rngKey(2).Cells(n, 1).value
　　　　sKey = Join(arKey, ",")
　　　　If dic.Exists(sKey) Then
　　　　　　arDat = Split(dic(sKey), ",")
　　　　　　dic.Remove sKey
　　　　End If
　　　　arDat(0) = Val(arDat(0)) + Val(rngDat(0).Cells(n, 1).value)
　　　　arDat(1) = Val(arDat(1)) + Val(rngDat(1).Cells(n, 1).value)
　　　　sDat = Join(arDat, ",")
　　　　dic.Add sKey, sDat
　　Next

　　' Sheet2を適切なオブジェクトに修正してください
　　Set r = Sheet2.Range("A2")
　　Dim dd() As Double
　　For n = 0 To dic.Count - 1
　　　　'Debug.Print n, dic.Items(n), dic.Keys(n)
　　　　arS = Split(dic.Keys(n), ",")
　　　　arD = Split(dic.Items(n), ",")
　　　　ReDim dd(UBound(arD))
　　　　For m = 0 To UBound(arD)
　　　　　　dd(m) = Val(arD(m))
　　　　Next
　　　　r.Resize(1, UBound(arS) + 1).value = arS
　　　　r.Offset(0, UBound(arS) + 1).Resize(1, UBound(arD) + 1).value = dd
　　　　Set r = r.Offset(1)
　　Next
End Sub

# 行頭には全角スペースがあります置換してください
# VBAの参照設定で『Microsoft Scripting runtime』を設定しています

お礼

じっくり学ばさせていただきます。有難うございました。またよろしくお願いします。

補足

redfox63様　以前もお世話になりました。またお世話になります。
2つもの提示有難うございます。私としては共に可読性が高く馴染み易い気がします。ただ、コレクションオブジェクトの場合の方は結果の集計が最初のKey分以外？うまく纏められてないようです。
Dictionaryの場合のほうは宣言部分（Dim dic As New Dictionary）でエラーです。もしかして「VBAの参照設定で『Microsoft Scripting runtime』を設定しています」と記載してくれてる分に対して私が理解出来てないせいでしょうか？
しかし私にとっても可読性の高いコードですので、これにItemを40個くらい加えて行く場所と記述を試行錯誤で覚えてゆけばいいと思ってます。少し試してみます。お礼は後ほど致します。

回答No.2

end-u

一応...ご提示のコードと同じような結果を出すPivot利用のサンプルです。
（動作検証はExcel2000しかやってません）

Option Explicit

Sub try()
　　Const rowF = "大区分 中区分 小区分"
　　Const dataF = "金額1 金額2"
　　Dim SH2 As Worksheet
　　Dim r　 As Range
　　Dim i　 As Long
　　Dim rowV, v

　　rowV = Split(rowF)
　　With ThisWorkbook
　　　　Set r = .Worksheets("元").Range("A1").CurrentRegion
　　　　Set SH2 = .Worksheets("集計")
　　　　SH2.UsedRange.ClearContents
　　　　With .PivotCaches.Add(SourceType:=xlDatabase, _
　　　　　　　　　　　　　　　SourceData:=r.Address(external:=True) _
　　　　　　　　　　　　　　　).CreatePivotTable(TableDestination:=SH2.Range("A1"))
　　　　　　.AddFields RowFields:=rowV, ColumnFields:="data"
　　　　　　For i = 0 To UBound(rowV) - 1
　　　　　　　　.PivotFields(rowV(i)).Subtotals(1) = False
　　　　　　Next
　　　　　　For Each v In Split(dataF)
　　　　　　　　With .PivotFields(v)
　　　　　　　　　　.Orientation = xlDataField
　　　　　　　　　　.Caption = v & "計"
　　　　　　　　　　.Function = xlSum
　　　　　　　　End With
　　　　　　Next
　　　　　　With .RowRange
　　　　　　　　Set r = .Resize(.Rows.Count - 1)
　　　　　　End With
　　　　　　With .TableRange2
　　　　　　　　.Copy
　　　　　　　　.PasteSpecial Paste:=xlPasteValues
　　　　　　　　.ClearFormats
　　　　　　End With
　　　　　　Application.CutCopyMode = False
　　　　　　On Error Resume Next
　　　　　　r.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
　　　　　　r.Value = r.Value
　　　　　　On Error GoTo 0
　　　　End With
　　　　SH2.Rows(1).Delete
　　End With

　　Set r = Nothing
　　Set SH2 = Nothing
End Sub

DictionaryのItemを配列にする方法については
http://oshiete1.goo.ne.jp/qa4388120.html
などを参考にされると良いかもしれません。
ですがシート転記時にまた分割しなければならないような？

なので、DictionaryのItemには追加時に連番をふりながら（その連番を）Indexとしてセットし、
『集計＆転記用の配列を別に用意』し、
Indexでその配列への加算位置を指定してあげるほうが簡単かもしれません。

補足

以前も助けてもらいました。今回分も含めましてまずはお礼申し上げます。
早速ピボット試させて頂きました。総計も含めズバッと出してくれます。ありがとうございます。これを元に範囲指定をCurrentRegionではなく飛び飛びの列対応に広げれば、対応できると思います。（あまりピボット得意ではないので少し不安ですが）
しかしながら、前述の理由によりもう一方のご提示に関心があります。そちらを中心に眺めさせて頂きました。複数Keyに関しては私の記載のコードのように一旦、結合してのち切り離すことで処理は出来るつもりですが、今回iteｍを列の数だけ同時に追加し、かつ同Keyで同列対象のitemは加算させるという方法が知りたいのです。出来そうだなぁと思ってますが、（飛び飛びの複数列といいましても列は固定です。）KeyにitemとしてCells（,）とCells（,）とCells（,）と沢山付ける記述のしかた、そして加算してゆく方法、そして切り離し転記する方法を覚えたいのです。お助け下さい。

回答No.1

end-u

Dictionaryでもできると思いますが、PivotTableのほうが適しているのではないでしょうか。
検討されましたか？
http://www11.plala.or.jp/koma_Excel/pivot_menu.html

補足

end-u様　ご返答下さいましてありがとうございます。それと表のレイアウトが崩れていることをお詫びいたします。1とか3とかの一桁の数字は小区分の位置です。
また、ピボットの件ですが、あまり詳しくないのも事実ではございますが、今回、項目ごとの結果の数字を個別に色々なシートに転記する予定ですので、ピボットテーブルのように項目ごとの結果の出力セルがあらかじめ特定出来ない（私の勘違いかもしれませんが）場合不都合なのです。またDictionaryをだいぶ使えるようになったので、勉強を兼ねて複数のITEMの時はどうすればいいのかなぁ？となっている次第です。
Arrayにitemをからめる等のヒントをネット上で見つけてこのへんなのかなとは思ってはいるのですがまだ理解出来てません。また列が40位あるのでその範囲を一気に呼びこんでもメモリは大丈夫かな？という不安もあります。とりあえず試してみたいと思ってます。わがままとは思いますが何卒よろしくお願いいたします。