VBA 複数シートに渡る連想配列

質問

Winは7、Excelは2013を使用しています。
画像の様に、シート2のＡ列の科目を連想配列のキーし、
シート2以降のシートのＢ列とＣ列のデータを同時に格納していきたいと思っています。

6月には、4～5月の2ヶ月分、7月には4～6月分の3ヶ月分、となるので、
シートの数だけ繰り返したいです。

それで、下記を自分で考えてみたのですが、
数々エラーになり、上手く行きません。
どなたか、ご教示頂けます様お願い致します。

Sub test_年間()
'---------------------------------------
'科目を連想配列に登録し、年間集計シートに書き出す
'---------------------------------------
Dim n As Integer
Dim maxRow As Integer

Dim Dic(36)
Dim buf As String
Dim Keys
Dim k As Integer
Dim a As Integer

For s = 2 To Worksheets.Count

Sheets(s).Activate

maxRow = Range("A65536").End(xlUp).Row

'------------------------------------
'格納
'------------------------------------

Set Dic(s) = CreateObject("Scripting.Dictionary")

For n = 2 To maxRow
buf = Cells(n, 1).Value 'A列のセルの値をbufに格納する
b = Cells(n, 2).Value 'B列のセルの値をbに格納する
c = Cells(n, 3).Value 'C列のセルの値をcに格納
If buf = "" Then '空白セルではなく
ElseIf Not Dic(s).Exists(buf) Then '辞書にまだ登録されていなければ
Dic(s).Add buf, b 'そのセルの値を連想配列に登録する。

'ここで　Dic(S+1).Add buf, c　のような事がしたいのですが....
'でもS+1はエラーになります。

End If
Next n

Next s

'---------------------------------------------
'書き出す
'---------------------------------------------
For s = 2 To Worksheets.Count

Keys = Dic(s).Keys

Worksheets("年間集計").Activate

With Worksheets("年間集計")

k = 1
a = 1
r = 0

For n = 0 To Dic(s).Count - 1
k = k + 1 '最初の書き出しは2行目から
Cells(k, 1 + r) = Keys(n)
Cells(k, 2 + r) = Dic(s)(Keys(n))
' Cells(k, 3 + r).NumberFormatLocal = "[h]:mm"
' Cells(k, 3 + r) = Dic(s + 1)(Keys(n))
r = r + 3

Next n
End With

Next s

Set Dic(s) = Nothing

MsgBox "終了"
End Sub

勝手申しますが、お礼は来週月曜日なります。
どうかお許し願います。

回答No.2

mt2015 · ベストアンサー

Sheet2、Sheet3のB列、C列に項目名を付けておきましょう(添付図参照）。

Sub Sample()
　　Dim sArray() As String
　　ReDim sArray(Sheets.Count - 2) As String
　　For i = 2 To Sheets.Count
　　　　sShtName = Sheets(i).Name
　　　　sShtAddress = Sheets(i).Range("A2").CurrentRegion.Address(, , xlR1C1)
　　　　sArray(i - 2) = sShtName & "!" & sShtAddress
　　Next i
　　Sheets(1).Range("A1").Consolidate Sources:=sArray, Function:=xlSum, TopRow:=True, LeftColumn:=True, CreateLinks:=False
End Sub

データの統合機能を使っています。

お礼

mt2015様

ご回答いただきありがとうございます。
また昨日お礼コメントをするはずが、遅くなってしまい申し訳ありません。

まだ実際に使用出来ていないのですが、
書いて下さった構文をよく拝見し勉強させて頂きたいと思っています。

回答No.5

SI299792

違っています。“."のついている所が入力元で、ついていないところが出力先です。

出力先が今まで通りＡ列の場合
　　For Row = 2 To .[A65536].End(xlUp).Row
の様に“."の有る所は直す必要があります。
　　　　　　Set Find = [A:A].Find(What, LookAt:=xlWhole)
の様に“."の無い所は直してはいけません。

出力先もＭ列からにしたいなら、全体にそのような修正をした上で、
　　　　Col = Sheet * 2 + 10
に直します。Col は列です。Ｍ列は13番目なので、13-3で出します。
Sheet は２から始まるので、こうすれば最初は2*2+10は14、つまりＮ列になります。

項目名を変更しても構わないのであれば、mt2015さんのやり方の方が優れていると思います

お礼

SI299792様

ご回答ありがとうございます。
変更する事ができました。

回答No.4

mt2015

ANo.2です。

「データの統合」について説明しておいた方が良いかと思ったので再度回答します。
以下の様な操作をしてみてください。
1.ANo.2の添付図の様に、Sheet2とSheet3のB1、C1に項目名を入れます。この時、「4月時間」の様に他とダブらない名前にします。
2.Sheet1のA1を選択した状態で、メニューのデータ→データツール→統合を選択します。
3.「統合の設定」ダイヤログで集計の方法：合計を選択
4.統合元範囲でSheet2のA1:C5を指定し、＜追加＞ボタンで統合元に追加。
5.同様に統合元範囲でSheet3のA1:C5を指定し、＜追加＞ボタンで統合元に追加。
6.統合の基準で、上端行と左端列にチェックをつけて＜OK＞ボタンを押下

これでSheet1にご希望の表が作成されたはずです。
同じことをSheet2以降の全てのシートのA2を含むセル範囲を統合元にしたものがANo.2のコードです。

お礼

mt2015様

いつも丁寧に解説下さり、ありがとうございます。
この回答だけお礼コメントが遅くなってしまい、申し訳ありません。

手作業でもこういう方法があるのは知りませんでした。
他の方に指摘されましたが、
Excelの色々な機能を知った上で、それがVBAにもつながるのですね。

VBAで作業を効率化したいと思っているだけでは良くないのかもしれませんが、
勉強して行きます。

回答No.3

imogasi

今更、質問者は、自分のやりかけた方法を変えるのは、非常に苦痛だろうから、下記は、今後の勉強ぐらいと思って読んでください。
ーー
（１）今後いろいろ勉強して、このタイプの課題に、プロなどは、連想記憶を使っているか、勉強することを強く勧める。どこかで連想記録を学んで、これは便利とほれ込んで使ったのだろうが、やりすぎと思う。小生は、「牛刀をもって鶏を割く」という古来の言葉を思い出した。
（２）普通はSQLなどを使って、情報を結合するだろう。
SQLつかソフトが、簡単に、使えない時代は、マッチングのアルゴリズムを使ってやっていた。
（３）下記は「Find法」ともいえるものでしょう。
毎レコードFindメソッドを使うので、処理速度的には、速いとは言えないと思う。
しかし、昔の紙ベースの作業の方式（コンピュターを使わない人が、目視で目的の表を作るときはどういうプロセスをやるか）を、なぞったやりかたなので、だれにもわかりやすいロジックです。VBAのコード数も、多分、他と比べて、少ないでしょう。
こちらの方法も、あまり見かけないけどね。
ーー
例データ
Sheet2　A1:C6
科目 情報１ 情報２
国語 12　 46
理科 13　 78
音楽 56　 78
英語 23　 56
図工 34　 89
ーー
Sheet3　A1:C6
科目 情報１ 情報２
国語 12　 34
英語 23　 45
理科 13　 56
図工 34　 76
音楽 56　 26
Sheet2とSheet３は、行的にまたデータ数値が違う例。
ーー
標準モジュールに
Sub test01()
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
Set sh3 = Worksheets("Sheet3")
Worksheets("Sheet2").Range("A1:C6").Copy Sheets("Sheet1").Range("A1")
For i = 2 To 6
Key = sh1.Cells(i, "A")
r = sh3.Columns("A").Find(Key).Row
'MsgBox r
Worksheets("sheet1").Cells(i, "D") = Cells(r, "B")
Worksheets("sheet1").Cells(i, "E") = Cells(r, "C")
Next i
sh3.Range("B1:C1").Copy sh1.Range("D1")
End Sub
ーー
実行する。
結果
科目 情報１ 情報２ 情報１ 情報２
国語 12　 46　 12　 34
理科 13 78 13　 56
音楽 56　 78　 56　 26
英語 23　 56　 23　 45
図工 34　 89　 34　 76
ーー
上記サンプルは、行数も、６と両方一致の例でやっているし、コードも行数６は行数を、相対化してなくて、少数例で手抜きしてます。
項目も、両方シートに、もれなく出現する例にしてます。
この点について、両シートで同じでない場合だと、そこがこのやり方のウイークポイントです。

お礼

imogasiさま

色々ご教示頂きありがとうございます。
私が考えた構文では行き詰まっていたので、
それより良い方法を教えて下さってありがたいです。

こういう表が良いという指示された年間集計の表があって、
それを手作業でやることはできますが、時間がかかるので、
マクロで何とかパっと処理したいというのが今の状況です。
書いて下さった構文をよく拝見し、勉強させて頂きます。

回答No.1

SI299792

この場合、連想配列は使わない方がいいです。面倒なだけです。Findなら、プログラムも簡単だし、実行速度も速いです。Findを使ったプログラムです。
'
Option Explicit
'
Sub Macro1()
'
　　Dim Sheet As Integer
　　Dim Col As Integer
　　Dim Row As Long
　　Dim What As String
　　Dim Find As Range
　　Dim RowOut As Long
'
　　Sheets("年間集計").Select
　　Cells.ClearContents
'
　　For Sheet = 2 To Sheets.Count
　　　　With Sheets(Sheet)
　　　　Col = Sheet * 2 - 2
　　　　Cells(1, Col) = .Name & .[B1]
　　　　Cells(1, Col + 1) = .[C1]
　　　　Columns(Col + 1).NumberFormatLocal = "h:mm;@"
'
　　　　For Row = 2 To .[A65536].End(xlUp).Row
　　　　　　What = .Cells(Row, "A")
　　　　　　Set Find = [A:A].Find(What, LookAt:=xlWhole)
'
　　　　　　If Find Is Nothing Then
　　　　　　　　RowOut = [A65536].End(xlUp).Row + 1
　　　　　　Else
　　　　　　　　RowOut = Find.Row
　　　　　　End If
　　　　　　Cells(RowOut, "A") = What
　　　　　　Cells(RowOut, Col).Resize(1, 2) = .Cells(Row, "B").Resize(1, 2).Value
　　　　Next Row
　　　　End With
　　Next Sheet
End Sub

　OKWAVEは、勝手に回答を改ざんします。この回答も改ざんされ、プログラムが動かなくなる可能性があります。他の質問サイトにした方が確実です。

お礼

SI299792様

ご回答いただきありがとうございます。
またお礼が遅くなってしまい申し訳ありません。

こういう時はFindを使ったプログラムのが良いのですね。
他の作業を言いつけられてしまい、
昨日今日と実際に使ってみる時間が取れていないのですが、
書いて下さったコードをよく拝見し、勉強させて頂きます。
ご教示頂きありがとうございます。

補足

SI299792様

もしよろしければ、申し少し教えて下さい。

各月のデータで、M～Ｏ列にあるデータも同じ様に処理したい場合、
この構文を使う事ができますか？

Option Explicit
'
Sub Macro1()
'
Dim Sheet As Integer
Dim Col As Integer
Dim Row As Long
Dim What As String
Dim Find As Range
Dim RowOut As Long
'
Sheets("年間集計").Select
Cells.ClearContents
'
For Sheet = 2 To Sheets.Count
With Sheets(Sheet)
Col = Sheet * 2 - 2
Cells(1, Col) = .[N1]
Cells(1, Col + 1) = .[O1]
Columns(Col + 1).NumberFormatLocal = "h:mm;@"
'
For Row = 2 To .[A65536].End(xlUp).Row
What = .Cells(Row, "M")
Set Find = [M:M].Find(What, LookAt:=xlWhole)
'
If Find Is Nothing Then
RowOut = [M65536].End(xlUp).Row + 1
Else
RowOut = Find.Row
End If
Cells(RowOut, "A") = What
Cells(RowOut, Col).Resize(1, 2) = .Cells(Row, "B").Resize(1, 2).Value
Next Row
End With
Next Sheet
End Sub

であってますか？