VBA同一項目をひとまとめにして別シートに整理された表を作成したい

質問

Sheet1～n

　　【 E　】 　 F 　 G 　 【H 】 　 I
種別　　　 単価　　　 合計　　　　種別B　　　個数
4　　　　　ア 　300 　100,000,000 　(1) 3
5　　　　　イ 　300 　100,000,000 　(2) 4
6 　ア 　300 　100,000,000 　 　(1) 　5
7 　イ 　300 　100,000,000 　(2) 　6
8 　ウ 　300 　100,000,000 　(3) 　5

Sheet1～ｎまで同じ形式の上記の表があり、
Sheetごとの、E列の種別A＝ア・イ・それ以外で、3つに分類し、
【F列】種別B（項目複数）ごとのF・G・I列の合計を出すマクロを作りたいのですが
まだまだレベルが低すぎてわかりません。

Sheetまとめの表

Sheet1
　種別A　　　種別B　　　F合計　　G合計　　I合計
　　ア　　　　(1)
　　ア　　　　(2)
　　ア　　　　(3)
　　イ　　　　(1)
　　イ　　　　(2)
　　以外　　　(1)
　　　　　　　(2)
Sheet1
　種別A　　種別B　　　F合計　　G合計　　I合計
　　ア　　　(1)
　　ア　　　(2)
　　ア　　　(3)
　　イ　　　(1)
　　イ　　　(2)
　　以外　　(1)
　　　　　　(2)
Sheet1
　種別A　種別B　　F合計　G合計　I合計
　　ア　　　(1)
　　ア　　　(2)
　　ア　　　(3)
　　イ　　　(1)
　　イ　　　(2)
　　以外　　(1)
　　　　　　(2)
Sheet2・・と続く。

ネットで見つけたコードですが複雑すぎてどこを変えればいいのかわかりません・・・（＞＜）
Option Explicit
Sub てすと()
Dim MyDic As Object
Dim MyA As Variant, MyAry() As Variant
Dim i As Long, n As Long, k As Long, x As Long
Set MyDic = CreateObject("Scripting.Dictionary")
With Worksheets("Sheet1")
MyA = .Range("A1", .Range("A65536").End(xlUp)).Resize(, 4).Value
End With
For i = 1 To UBound(MyA, 1)
If Not MyDic.Exists(MyA(i, 1) & MyA(i, 2)) Then
k = k + 1
ReDim Preserve MyAry(1 To UBound(MyA, 2), 1 To k)
MyDic.Add MyA(i, 1) & MyA(i, 2), k
For n = LBound(MyA, 2) To UBound(MyA, 2)
MyAry(n, k) = MyA(i, n)
Next
Else
x = MyDic(MyA(i, 1) & MyA(i, 2))
For n = 3 To UBound(MyA, 2)
MyAry(n, x) = MyAry(n, x) + MyA(i, n)
Next
End If
Next
With Worksheets("Sheet2")
.Range("A1").CurrentRegion.ClearContents
.Range("A1").Resize(UBound(MyAry, 2), 4).Value = Application.Transpose(MyAry)
End With
Erase MyA, MyAry
End Sub

回答No.4

kenpon24 · ベストアンサー

帰ってくるのが遅くなりました。

>データはEからで1～3行は見出しで結合セルです
ではデータはE4セルから始まっているんですか？

とりあえずコードは貼り付けておきますので、ブレークポイントで止めながら確認していってください。
集計用のシートとして、「Sheetまとめ」って名前のシートがあることを前提にしてます。名前は自分で変えてもらっても結構ですし、自動で生成するようにするのもいいでしょう。

できるだけサンプルの形を保とうと思ったのですが、もともと読みにくかったので崩してしまいました。

'-----コード開始 適当にインデントすること----
Option Explicit

Sub てすと()

Dim MyDic As Object
Dim Mysheet As Worksheet

Dim MyA As Variant, MyAry() As Variant '取り込み、貼り付け用の配列
Dim NowRow As Long, NowCol As Long '処理中の配列の添え字
Dim DicNum As Long '連想配列の要素数
Dim DicCol As Long '連想配列の添え字
Dim PastePos As Long '現在の貼り付け位置
Dim Bottom As Long '処理中のシートの最終行

Const StartRow As Long = 4 'データの開始行　もしE1からデータが始まってるなら1にすること
Const key1 As Integer = 1 '種別AのOFFSET
Const key2 As Integer = 4 '種別BのOFFSET
Const ColSize As Integer = 5 '表の要素数
Const MixSheet As String = "Sheetまとめ" 'まとめるシートの名前

'Set Mysheet = Worksheets("Sheet1")
PastePos = 1

'まとめシートの初期化
Worksheets(MixSheet).Cells.ClearContents

'まとめシートを除くすべてのシートを処理
For Each Mysheet In Worksheets

If Mysheet.Name = MixSheet Then
GoTo Next_s
End If

Set MyDic = CreateObject("Scripting.Dictionary")

'シートに格納されているデータをMyAに格納
With Mysheet
Bottom = .Range("E65536").End(xlUp).Row
MyA = .Range("E" & StartRow & ":E" & Bottom).Resize(, ColSize).Value
End With

For NowRow = 1 To UBound(MyA, 1)
'key1列の指定文字列以外は"以外"にする
If MyA(NowRow, 1) <> "種別A" And MyA(NowRow, 1) <> "ア" And MyA(NowRow, 1) <> "イ" Then
MyA(NowRow, 1) = "以外"
End If

If Not MyDic.Exists(MyA(NowRow, key1) & MyA(NowRow, key2)) Then
'リストに未登録のとき、登録する
DicNum = DicNum + 1
MyDic.Add MyA(NowRow, key1) & MyA(NowRow, key2), DicNum

'列のサイズ ×　1列だけ配列のサイズを増やす
'Redim Preserveは末尾の要素しか動的に確保できない
ReDim Preserve MyAry(1 To UBound(MyA, 2), 1 To DicNum)

'要素の代入
For NowCol = LBound(MyA, 2) To UBound(MyA, 2)
MyAry(NowCol, DicNum) = MyA(NowRow, NowCol)

'最初の列で、かつkey1でもkey2でもないとき、合計という文字を追加する
If NowRow = LBound(MyA, 2) And (NowCol <> key1 And NowCol <> key2) Then
MyAry(NowCol, DicNum) = MyAry(NowCol, DicNum) & "合計"
End If
Next
Else
'登録済みのとき、加算する
'連想配列の添え字を取得する
DicCol = MyDic(MyA(NowRow, key1) & MyA(NowRow, key2))

For NowCol = 1 To UBound(MyA, 2)
'key1列とkey2列は加算対象外
If NowCol <> key1 And NowCol <> key2 Then
MyAry(NowCol, DicCol) = MyAry(NowCol, DicCol) + MyA(NowRow, NowCol)
End If
Next
End If
Next

'値を貼り付ける
With Worksheets(MixSheet)
.Activate
'key2列の(1)が-1となるので、あらかじめ文字列にする
.Columns(key2).NumberFormatLocal = "@"
.Range("A" & PastePos) = Mysheet.Name
PastePos = PastePos + 1
'行列を反転して貼り付け
.Range("A" & PastePos).Resize(UBound(MyAry, 2), ColSize).Value = Application.Transpose(MyAry)
'key1, key2で昇順にソート
.Range("A" & PastePos + 1).Resize(UBound(MyAry, 2) - 1, ColSize).Sort _
key1:=Cells(PastePos + 1, key1), Order1:=xlAscending, key2:=Cells(PastePos + 1, key2), Order2:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
End With
'次回貼り付け行数を格納
PastePos = PastePos + UBound(MyAry, 2) + 1
DicNum = 0
Erase MyA
Erase MyAry
Set MyDic = Nothing

Next_s:
Next

'key2列を2列目に挿入
With Worksheets(MixSheet)
.Columns(key2).Cut
.Columns("B:B").Insert
End With

End Sub

'-----以上　終----

お礼

Error　Resume　next
をつけたら、空白のときも上手くいきました。
ありがとうございました。
丁寧な解説と、すばらしいコード・・・。
すごく助かりました。

補足

ありがとうございます。
さらに難しいコードで・・・（汗
びっくりしました。

.Range("A" & PastePos + 1).Resize(UBound(MyAry, 2) - 1, ColSize).Sort _
key1:=Cells(PastePos + 1, key1), Order1:=xlAscending, key2:=Cells(PastePos + 1, key2), Order2:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
のところで、アプリケーションまたはオブジェクト定義のエラーになります・・・。
シートがたくさんあり、データ欄が空白のものもたまにあります。
そのせいでしょうか？？？

回答No.3

n-jun

>ネットで見つけたコードですが複雑すぎてどこを変えればいいのかわかりません・・・（＞＜）
せめて何をするためのコードかは、書いてあったのですか？

＞Sheet1～ｎまで同じ形式の上記の表があり
同じBookですよね？
結果はどこに出すのでしょうか？
３シート追加する？

補足

同一ブック内に大量のシートがあります
集計はシート作成でも最初にシートを作っておくのでもかまいません

えー、ネットで拾ったコードは２つの条件を指定できる集計のコードです。
種別A種別Bごとの集計で種別が何種類でも集計できるものらしいです

回答No.2

n-jun

Sheet１が３つあるのは、Bookが３つあるって事？
単に転記ミス？

ア・イ・それ以外の３つのSheetを作りたいとか？

補足

転記ミスです
すみません

回答No.1

kenpon24

今コード書いてて、夜にはアップできると思いますけど、
サンプルのままじゃ全然足りませんよ。

コメント書いてないサンプルもどうかとは思いますが、
わからない箇所はヘルプやwebで調べたり、やりたい動作を
自動記録してみるなりして、少しは絞って質問してください。

それと、E列の種別は種別Aってことでいいんですよね？
>Sheet1～n
>　　【 E　】 　 F 　 G 　 【H 】 　 I
>種別　　　 単価　　　 合計　　　　種別B　　　個数

あと、まとめの表にsheet1が3つあるのは何を意味するんですか？
sheet1
sheet2
sheet3
sheet4...と続くって意味でいいんですよね？

お礼

すみません。昼間ケータイからレスつけたため
ちゃんと書けてませんでした。

データシートはいっぱいあります。
>Sheet1～n
>【 E　】 　 F 　 　　　G 　 　　　　【H 】 　　 I
>種別A　　　 単価　　　 合計　　　　種別B　　　個数

合計したいのは、
種別Aごとの種別BごとのF・G・Iの合計です。

シート1
種別A＝ア
種別B＝(1)　F合計　G　合計　I合計

種別A＝ア
種別B＝(2)　F合計　G　合計　I合計

種別A＝ア
種別B＝(3)　F合計　G　合計　I合計

種別A＝イ
種別B＝(1)　F合計　G　合計　I合計

種別A＝イ
種別B＝(2)　F合計　G　合計　I合計

シート2
種別A＝ア
種別B＝(1)　F合計　G　合計　I合計
　　：
　　：
こんな感じです。
数字がほしいだけなので形式は問わないのですが。。。

補足

データはEからで1～3行は見出しで結合セルです
そのせいでいろんなサンプルを調べましたがうまく行きませんでした(@_@;)