一気にdictionaryで飛び飛びの複数列をkeyとして集計し別BOOKに縦横並び替えしたい

質問

元BOOK　Sheet1～Sheet30前後（どのシートも記入内容は違うが同じ構成）
　　A　　　H　　　I　　　　J　　　K　　　L　　　M　　　N 　　O
1　コード　数　　単位　単価　分類　　数　　単位　単価　分類
2　J-1　　1　　　時間　1000　　　B　　　1　　時間　1500　　C
3　K-1　　1　　　名　　20000　　A　　　2　　時間　1000　　B
4　J-1　　2　　　名　　15000　　A　　　3　　時間　1000　　B

先BOOK　元BOOKと同じシート枚数だが横の要素を縦に並び替えるため行数は増える（列数は並び替えにより減るが、計の1列だけが新規に増加）
　　A　　　B　　　C　　　　D　　　　E　　　　F　　
1　コード　数　　単位　単価　　　計　　　分類　　
2　J-1　　2　　　名　　 15000　　30000　　A
3　　　　 4　　　時間　　1000　　4000　　　B
4　　　　 1　　　時間　　1500　　1500　　　C
5　K-1　　1　　　名　　 20000　　20000　　A
6　　　　 2　　　時間　　1000　　2000　　　B

　望みは元BOOKをシート別にコードごとに集計し、抽出結果を先BOOKに元BOOKのシート別に書き出したいのです。
　例ではHIJK、LMNOの各4列が1セットで（数、単位、単価、分類）2セット例示してますが、実際にはPQRSも加え3セットです。（空欄のセットもあります）
　実際の表は、1行目は見出しで、縦方向は300行位の表です。横方向は40列位あります。（コードは各シート各行ともA列で、数、単位、単価、分類のセットは連続した4列で1セットで、各シート各行ともH列スタートで3セット連続しています←HIJK、LMNO、PQRS）
　コードにたいして横方向に列挙されているセットの要素をコード別に縦方向に並び替えをしたいのですが、(元BOOKのセットの空欄は不要で1行1セットにしたい)その際にコードと単位、単価、分類の4つが一致するものの数を合算し、その合算された数量と単価を掛けて単価の右隣に記入し、そのさらに右隣に分類を書き戻す。また元BOOKの各SheetのA列の途中には空欄の行はなく、同行内の横方向のセット同士で合算されるものはありません。
　一般的なdictionaryの使い方は理解しております。よってdictionaryでA列のコードに単位、単価、分類を&"-"&で結合し文字列にしたものをkeyとし、数をitemをにして合算する。Splitでkeyを戻す？のようなイメージのみあるのですが、列方向に3要素有るのでdictionaryの廻し方と、並び替えが解りません。さらに出来れば、コードごとでの並び替えを分類を基準に優先順位を持たせたいのです。例示ではABC順ですが実際は様々な言葉ですので　ソート順を　ary = (ああ,い,けこ,うお)のように配列で書き込んでおく等で対処出来ればいいなと思う次第です。
本当にわがままだらけで申し訳なく思っております。しかしながら、段階的手法、もしくは、断片的でも非常に助かりますので何卒お助けくださいませ。気長にお待ちしております。よろしくお願い致します。

回答No.1

n-jun · ベストアンサー

アクティブシートの結果をＳｈｅｅｔ２に書き出します。
ただし並び替えや重複するコードの削除はしてません。

Sub try()
Dim myDic As Object
Dim r As Range
Dim st As String
Dim i As Integer
Dim v As Variant

Set myDic = CreateObject("Scripting.Dictionary")

For Each r In Range("H2", Cells(Rows.Count, "H").End(xlUp))

For i = 0 To 8 Step 4
If r.Offset(, i).Value = "" Then Exit For

v = Array(Range("A" & r.Row).Value, r.Offset(, i + 1).Value, _
r.Offset(, i + 2).Value, r.Offset(, i + 3).Value)
st = Join(v, "_")

If Not myDic.Exists(st) Then
myDic(st) = Array(v(0), r.Offset(, i).Value, v(1), v(2), _
r.Offset(, i).Value * v(2), v(3))

Else
myDic(st) = Array(v(0), r.Offset(, i).Value + myDic(st)(1), v(1), v(2), _
myDic(st)(4) + r.Offset(, i).Value * v(2), v(3))
End If

Next
Next

With Worksheets("Sheet2")
.Range("A1:F1").Value = Array("コード", "数", "単位", "単価", "計", "分類")
.Range("A2").Resize(myDic.Count, 6).Value = Application.Transpose(Application.Transpose(myDic.Items))
End With

Set myDic = Nothing
Erase v
End Sub

ご参考程度に。

お礼

n-junさん。有難うございます。昨年9月にも助けて頂きました。重ねて御礼申し上げます。北朝鮮からのエアメール（もうすぐ私の誕生日でしたので、素敵な贈り物？）が気になってまして、返事遅れました。
For i = 0 To 8 Step 4
と
.Range("A2").Resize(myDic.Count, 6).Value = Application.Transpose(Application.Transpose(myDic.Items))
この辺りに考えが及んでませんでした。また、横方向の合算は必要はないのですが、あっても助かることのみなので、助かりました。
後は並び替えでソートできますので、完璧です。
もしかするとこの後、コード名ごとのシートに分けつつ色々作業との段階でまたつまづくかも知れません。その際は、もし御手隙でしたら
よろしくお願いします。ありがとうございました。yokokama46