こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

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

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

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

投稿日時 - 2018-06-15 16:41:41

QNo.9508592

困ってます

質問者が選んだベストアンサー

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

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

投稿日時 - 2018-06-15 18:32:54

お礼

mt2015様

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

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

投稿日時 - 2018-06-19 10:41:14

ANo.2

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(5)

ANo.5

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

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

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

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

投稿日時 - 2018-06-22 08:34:00

お礼

SI299792様

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

投稿日時 - 2018-06-22 17:33:06

ANo.4

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のコードです。

投稿日時 - 2018-06-18 09:41:28

お礼

mt2015様

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

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

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

投稿日時 - 2018-06-19 15:56:42

ANo.3

今更、質問者は、自分のやりかけた方法を変えるのは、非常に苦痛だろうから、下記は、今後の勉強ぐらいと思って読んでください。
ーー
(1)今後いろいろ勉強して、このタイプの課題に、プロなどは、連想記憶を使っているか、勉強することを強く勧める。どこかで連想記録を学んで、これは便利とほれ込んで使ったのだろうが、やりすぎと思う。小生は、「牛刀をもって鶏を割く」という古来の言葉を思い出した。
(2)普通はSQLなどを使って、情報を結合するだろう。
SQLつかソフトが、簡単に、使えない時代は、マッチングのアルゴリズムを使ってやっていた。
(3)下記は「Find法」ともいえるものでしょう。
毎レコードFindメソッドを使うので、処理速度的には、速いとは言えないと思う。
しかし、昔の紙ベースの作業の方式(コンピュターを使わない人が、目視で目的の表を作るときはどういうプロセスをやるか)を、なぞったやりかたなので、だれにもわかりやすいロジックです。VBAのコード数も、多分、他と比べて、少ないでしょう。
こちらの方法も、あまり見かけないけどね。
ーー
例データ
Sheet2 A1:C6
科目情報1情報2
国語12 46
理科13 78
音楽56 78
英語23 56
図工34 89
ーー
Sheet3 A1:C6
科目情報1情報2
国語12 34
英語23 45
理科13 56
図工34 76
音楽56 26
Sheet2とSheet3は、行的にまたデータ数値が違う例。
ーー
標準モジュールに
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
ーー
実行する。
結果
科目情報1情報2情報1情報2
国語12 46 12 34
理科137813 56
音楽56 78 56 26
英語23 56 23 45
図工34 89 34 76
ーー
上記サンプルは、行数も、6と両方一致の例でやっているし、コードも行数6は行数を、相対化してなくて、少数例で手抜きしてます。
項目も、両方シートに、もれなく出現する例にしてます。
この点について、両シートで同じでない場合だと、そこがこのやり方のウイークポイントです。

投稿日時 - 2018-06-16 18:44:52

お礼

imogasiさま

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

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

投稿日時 - 2018-06-19 10:48:17

ANo.1

 この場合、連想配列は使わない方がいいです。面倒なだけです。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は、勝手に回答を改ざんします。この回答も改ざんされ、プログラムが動かなくなる可能性があります。他の質問サイトにした方が確実です。

投稿日時 - 2018-06-15 18:25:22

補足

SI299792様

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

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

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

であってますか?

投稿日時 - 2018-06-21 13:15:12

お礼

SI299792様

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

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

投稿日時 - 2018-06-19 10:38:17

あなたにオススメの質問