• ベストアンサー

VBA【dictionary勉強中ですが・・・】集計マクロ

いつもお世話になっております。 現在dictionary勉強中ですが、なかなかコツをつかめず 思ったとおりのマクロを作成することができません(ノ_;) ところで、今回作成しているのは 元データ.xlsというファイルのシート(データ)に   |【A】| B | C |【D】| E | F |・・・|H|I|【J】|K 3  【顧客ID】|顧客|受付日|【担当】|・・・|【会場名】|(見出し) 4  データの始まり↓ と、ありまして、 集計データ.xlsのシート(集計)に  | A | B | C | D | E | F | 1 顧客ID|担当|会場名| と二行目から一覧表があります。 A列のIDが一致するものに Sheet(データ)  →  Sheet(集計)  セル( i, "D")の値 → セル( j, "B") に セル( i, "J")の値 → セル( j, "C")に     セル(j,"C")に値が入っているとき、セル(j,"D")に→Fまで(4回のみ) A列のIDが一致するものがない時 セル( i, "A")の値 → セル( 最終,"A")に  セル( i, "D")の値 → セル( 最終, "B") に セル( i, "J")の値 → セル( 最終,"C")に追加 というように、入れたいのですが、 以下のようなコードをネットで見つけ自分なりに考えて変更を加えてみましたが あまり分かっていないためどのように変更すればいいのかよく分かりません。どなたかご教授ください。お願いします。 Sub Try() Dim data_1() As String Dim data As Long Dim maxrow As Long Dim t As Integer, f As Integer, y As Integer Set ws1 = Worksheets("集計") Set ws2 = Worksheets("データ") Application.ScreenUpdating = False maxrow = ws2.Range("a65536").End(xlUp).Row With ws1 For i = 2 To Range("a65536").End(xlUp).Row data = .Cells(i, 1) f = 0 t = 0 With ws2 t = Application.WorksheetFunction.CountIf(.Range("a4:a" & maxrow), data) If t > 0 Then For n = 1 To maxrow ReDim Preserve data_1(f) If data = .Cells(n, 1) Then data_1(f) = .Cells(n, 10) f = f + 1 If t = f Then Exit For Else 'A列にIDが存在しなければ追加する:ここの記述がよく分かりません。 data_1(f) = .Cells(n, 1) End If Next n For y = 0 To UBound(data_1) ws1.Cells(i, maxcol(i)) = data_1(y) Next y End If End With Next i End With Application.ScreenUpdating = True End Sub '-------------------------- Private Function maxcol(ByVal i As Long) As Integer Dim j As Integer With Worksheets("集計") j = 4 Do While .Cells(i, j) <> "" j = j + 1 Loop maxcol = j End With End Function

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

  • ベストアンサー
  • end-u
  • ベストアンサー率79% (496/625)
回答No.10

>二回目 >   A | B | C   | D   | E | F | >1 顧客ID|担当 |会場名(1)|会場名(2)| >  2005 |山田 |会場A  |会場B  | >  2006 |田中 |空白   |会場C  | これは、空白セルは詰めないという事ですね。 その場合は以下のように修正が必要です。 Sub try2()   'VBE[ツール][参照設定]で『Microsoft Scripting Runtime』にチェック   Dim ws As Worksheet   Dim dic As Scripting.Dictionary   Dim v  As Variant '集計データ格納用配列   Dim w  As Variant '元データ格納用配列   Dim i  As Long   Dim j  As Long   Dim k  As Long   Dim x  As Long      With Workbooks("元データ.xls").Sheets("データ")     w = .Range("J4", .Cells(.Rows.Count, 1).End(xlUp)).Value   End With      Set ws = Workbooks("集計データ.xls").Sheets("集計")   With ws.Cells(1).CurrentRegion     x = .Rows.Count     k = .Columns.Count + 1     v = .Resize(x + UBound(w), k).Value   End With   v(1, k) = "会場名(" & k - 2 & ")"      Set dic = New Scripting.Dictionary   For i = 1 To x     dic(v(i, 1)) = i   Next      For j = 1 To UBound(w)     If dic.Exists(w(j, 1)) Then       i = dic(w(j, 1))       v(i, k) = w(j, 10)     Else       x = x + 1       dic(w(j, 1)) = x       v(x, 1) = w(j, 1)       v(x, 2) = w(j, 4)       v(x, k) = w(j, 10)     End If   Next      With ws.Cells(1).Resize(x, k)     .ClearContents     .Value = v   End With      Set dic = Nothing   Set ws = Nothing End Sub ※2回目実行前にはD列には何も入力しておかない事、  3回目実行前にはE列には何も入力しておかない事、が条件です。 ついでに事前に[参照設定]する書き方にしてみました。(事前バインディング) そうしておくと、 dic. のあとに[プロパティ/メソッドの一覧]が表示されるVBEインテリセンス(入力支援)が効きますから コーディングが楽になるでしょう。

その他の回答 (13)

  • onlyrom
  • ベストアンサー率59% (228/384)
回答No.14

またまたまた登場、onlyromです。 前回のダブりの例、もうひとつ場合が抜けたました。 (例1: IDと会場名セットでのダブり) 4行目__2005__AA  5行目__2005__AA 6行目__3333__XX (例2: IDのみのダブり ) 4行目__2005__AA  5行目__2005__BB 6行目__3333__XX 何れにしろ、エラーというものは入力時点でチェックされるものあり、 また、今回の目的は「Dictionaryオブジェクトの理解」ですので、 エラーチェックという余計なコードを増やすのは、その妨げになると考えます。 よって、上記、例1、2とも正しいデータとして扱います。   ●テストデータを以下のように作成して実行してください。 (1)元データ.xlsも集計データ.xlsもそれぞれ新しいブックを作成する (2)本データの一部コピーして、データシートを作成する (3)集計データには、(2)で作成したデータの最後のデータのIDは入れないで新規にしておく (4)1回実行したあと、同じデータの最後に、新IDのデータを入れ2回目を実行する このようにすれば上手くいったかどうかの判断がし易いでしょう。 '--------------------------------------------------  Sub Test()  Dim R As Long  Dim Clm As Integer  Dim LastRow As Long  Dim TargetRow As Long  Dim BookPath As String  Dim OldClm As Integer  Dim myDic  Set myDic = CreateObject("Scripting.Dictionary")  Sheets("集計").Select  For R = 2 To Cells(Rows.Count, "A").End(xlUp).Row    If myDic.Exists(Cells(R, "A").Value) = False Then      myDic.Add Cells(R, "A").Value, R    End If    Clm = Cells(R, Columns.Count).End(xlToLeft).Column    If Clm > OldClm Then      OldClm = Clm    End If  Next R  If OldClm < 2 Then OldClm = 2  BookPath = ThisWorkbook.Path  Workbooks.Open BookPath & "\元データ.xls"  With ThisWorkbook.Sheets("集計")   For R = 4 To Cells(Rows.Count, "A").End(xlUp).Row     If myDic.Exists(Cells(R, "A").Value) Then       TargetRow = myDic.Item(Cells(R, "A").Value)       .Cells(TargetRow, "B").Value = Cells(R, "D").Value       Clm = .Cells(TargetRow, .Columns.Count).End(xlToLeft).Column       If Clm < OldClm Then         Clm = OldClm       End If       .Cells(TargetRow, Clm + 1).Value = Cells(R, "J").Value     Else       LastRow = .Cells(Rows.Count, "A").End(xlUp).Row       .Cells(LastRow + 1, "A").Value = Cells(R, "A").Value       .Cells(LastRow + 1, "B").Value = Cells(R, "D").Value       .Cells(LastRow + 1, OldClm + 1).Value = Cells(R, "J").Value       myDic.Add Cells(R, "A").Value, LastRow + 1     End If   Next R  End With  Workbooks("元データ.xls").Close False End Sub '------------------------------------------------------- テスト用の集計データ.xls、元データ.xlsはともに同じフォルダーに入れて実行。 それから、end-uさんのDictionaryを使ったもの、No12のDictionaryを使ってないものも、end-uさんのいう条件のもとで試してください。 スキルアップのためにきっと役立つはずです。 以上。  

Rin-u_u
質問者

お礼

いろいろと勉強になりました。 色んなコードを知ることができすごく感謝しています。 ありがとうございました。

  • onlyrom
  • ベストアンサー率59% (228/384)
回答No.13

またまた登場、onlyromです。 >常に会場データはJ列に入っており、 >元データの顧客IDを集計の顧客IDに一致する場所のC以降に >会場データを入れていくというかんじです。 それは最初から理解しておりまする。(^^;;; >(1回目) >2005 は ダブりあり、”AA”、”BB” >”AA”、”BB”と二つ入っていることはありません。 これも理解しています。 当方がダブりと言いましたのは (データシート) 4行目__2005__AA  5行目__2006__CC 6行目__2005__AA このようなものを指しています。 4行目と6行目でID番号2005がダブっていますよね。 こういうことはない、ということですか?   最初の質問で、重複4つと言ったのはこういうことだと解釈しましたが。。。   何れにしろどういうデータであれ動作するコードは仕上げてありますが、 一応、上記の補足があった時点でアップすることにしたいと思います。   >今回のケースは、ディクショナリが勉強できていない上に >ルーチンもちょっと自分にはまだ背伸びしすぎのコードです。 >ホントにありがとうございます。 初めは誰でもそうです。OJTこそがスキルアップのコツです。 頑張る人を応援する、至極当然のことだと考えます。 end-uさんもきっとそうでしょう。 同じことをするにも色んなコードの書き方があります。 色々参考にして頑張りませう。 以上。

Rin-u_u
質問者

補足

ありがとうございます。 4行目__2005__AA  5行目__2006__CC 6行目__2005__AA こういうダブりは基本的には無いはずです。 ただ、件数が多く、使う人も複数ですので 何かの間違いで入ってしまっていることは考えられますが・・・(汗

  • end-u
  • ベストアンサー率79% (496/625)
回答No.12

難解だとは思いますが、Dictionaryオブジェクトを使わない別解法を。 Sub try3()   Dim rd As Range '元データ範囲   Dim rs As Range '集計データ範囲   Dim ra As Range 'データ追加先      Set rs = Workbooks("集計データ.xls").Sheets("集計").Cells(1).CurrentRegion   Set ra = rs.Offset(rs.Rows.Count).Range("A1:B1")   '項目名をコピー。   rs.Range("A1:B1").Copy ra   With Workbooks("元データ.xls").Sheets("データ")     '3行目の項目名も含めて元データ範囲をセット。     Set rd = .Range("J3", .Cells(.Rows.Count, 1).End(xlUp))     With .Range("IV1:IV2")       .Cells(1).Value = "条件"       .Cells(2).Formula = "=ISNA(MATCH(A4," & _                  rs.Columns(1).Address(external:=True) & ",0))"       rd.AdvancedFilter Action:=xlFilterCopy, _                CriteriaRange:=.Cells, _                CopyToRange:=ra       .Clear     End With   End With   '追加した項目名の行を削除   ra.EntireRow.Delete   '集計データ範囲を再セット。   Set rs = rs.CurrentRegion   With rs.Offset(, rs.Columns.Count).Columns(1)     .Value = Application.VLookup(rs.Columns(1), rd, 10, 0)     .Replace "#N/A", ""   End With      Set ra = Nothing   Set rs = Nothing   Set rd = Nothing End Sub ポイントは、 1)存在確認とデータ追加を、計算検索条件によるAdvancedFilterメソッドで一気にやってしまう。  http://support.microsoft.com/kb/402757/ja 2)配列を返すApplication.VLookup関数で、まとめて値をセットする。 ...という感じで、Loopなしのパターンでシンプルに処理してみました。 Sheets("集計")のA1:B1セルの項目名と、Sheets("データ")のA3,D3セルの項目名が一致していれば うまくいくはずです。 #うまくいかなくても、これは蛇足の参考コードなのであまり気にしないでください。 それではこの辺で。がんばってください。

Rin-u_u
質問者

お礼

いろいろと勉強になりました。 色んな種類のコードを書いてくださってお手数おかけいたしました。 とっても感謝しています。 ありがとうございました。

  • onlyrom
  • ベストアンサー率59% (228/384)
回答No.11

あちゃーーー、 >  2006 |田中 |空白   |会場C  end-uさんの回答の最初を見てこれを見落としていたことに気づきました。 申し訳ありませぬ。。(^^;;; で、以下を確認。 ------------------------------------------------- (1回目) 2005 は ダブりあり、”AA”、”BB” 2006 は 空白データ 顧客ID 会1 会2 2005 AA BB 2006 ●● ●● ------------------------------------------------ 2回目 2005 は 空白データ 2006 は ”CC” 3003 は、新規でダブり ”DD”と”EE” 顧客ID 会1 会2 会3 会4 2005 AA BB ●● ●● 2006 ●● ●● CC ●● 3003 ●● ●● DD EE ------------------------------------------------- ダブりがあると上記のようになるので、 見出しの会場名1、会場名2・・・と、 マクロ実行の1回目、2回目・・・は関係ないことになります。 ということは集計シートを一見しても直ぐには マクロ実行の1回目、2回目・・・は分かりませんが それはいいのですね。   もうひとつ。 ほんとうにダブりはあるのでしょうか。 補足などではダブりはないように思えますが。 ダブりがなければ、前回処理で会社名がどの列まで入ったかを検索するのが簡単になります。 上記のようにダブりがあるということなら、コードが数行増えます。 が、▲▲何らの条件にも拘束されません。▲▲ (余談) end_uさんも仰ってますが、質問の件は、Dictionaryオブジェクトを勉強するにはちょっと。。です。 なぜならDictionaryよりも他のルーチンが質問者にはややこしいのではと思われます。 Dictionaryを勉強するにはも少しシンプルなデータを用いて習得すべきだと考えます。 以上。

Rin-u_u
質問者

補足

何度も気にかけていただいてすみません。 常に会場データはJ列に入っており、 元データの顧客ID を集計の顧客IDに一致する場所のC以降に 会場データを入れていくというかんじです。 説明が下手です。すみません。 (1回目) 2005 は ダブりあり、”AA”、”BB” ↑”AA”、”BB”と二つ入っていることはありません。 2006 は 空白データ (1回目) 顧客ID 会1  2005 AA  2006 ●●  ------------------------------------------------ 2回目 2005 は 空白データ 2006 は ”CC” 3003 は、新規”DD” 顧客ID 会1 会2 会3 会4 2005 AA ●● 2006 ●● CC  3003 ●● DD  ------------------------------------------------- 今回のケースは、ディクショナリが勉強できていない上に ルーチンもちょっと自分にはまだ 背伸びしすぎのコードです。 ホントにありがとうございます。

  • onlyrom
  • ベストアンサー率59% (228/384)
回答No.9

再度の登場、onlyromです。 '-------------------------------------------------  Sub Test()  Dim R As Long  Dim Clm As Integer  Dim LastRow As Long  Dim TargetRow As Long  Dim BookPath As String  Dim myDic  Set myDic = CreateObject("Scripting.Dictionary")  Sheets("集計").Select  For R = 2 To Cells(Rows.Count, "A").End(xlUp).Row    If myDic.Exists(Cells(R, "A").Value) = False Then      myDic.Add Cells(R, "A").Value, R    End If  Next R  BookPath = ThisWorkbook.Path  Workbooks.Open BookPath & "\元データ.xls"  With ThisWorkbook.Sheets("集計")   For R = 4 To Cells(Rows.Count, "A").End(xlUp).Row     If myDic.Exists(Cells(R, "A").Value) Then       TargetRow = myDic.Item(Cells(R, "A").Value)       .Cells(TargetRow, "B").Value = Cells(R, "D").Value       Clm = .Cells(TargetRow, Columns.Count).End(xlToLeft).Column       .Cells(TargetRow, Clm + 1).Value = Cells(R, "J").Value     Else       LastRow = .Cells(Rows.Count, "A").End(xlUp).Row       .Cells(LastRow + 1, "A").Value = Cells(R, "A").Value       .Cells(LastRow + 1, "B").Value = Cells(R, "D").Value       .Cells(LastRow + 1, "C").Value = Cells(R, "J").Value       myDic.Add Cells(R, "A").Value, LastRow + 1  '●重要     End If   Next R  End With  Workbooks("元データ.xls").Close False End Sub '-----------------------------------------------------  ●重要 、について 集計シートにないIDは、集計シートの最後に追加するのですが、 さらに、そのIDが重複もしてる場合も想定しているため。   尚、上記コードはわざとオブジェクト変数は使ってありませんが 実際は、Select,Activateメソッドなど使用しないように オブジェクト変数を使う方がベターでしょう。 それから、元データ.xlsはThisworkbookのPathから開いています。   以上。

Rin-u_u
質問者

お礼

ありがとうございます。 非常にわかりやすく わたしのレベルに合わせてくださっているということが すごくよくわかります。 本当に感謝いたします。

  • onlyrom
  • ベストアンサー率59% (228/384)
回答No.8

質問、補足など読んでいくといくつか重要な点が抜けてます。 それらを補足してください。 さすれば質問者のレベルに合わせたDictionaryオブジェクトをアップすることに吝かではありませぬ。   (1)コードは、元データ.xls、集計データ.xlsのどちらに書いてあるのか (2)元データ.xls、集計データ.xlsは予め両方とも開いているか (3)集計データ.xlsの転記されるエリアはマクロ実行の最初でクリアーしなくていいのか (4)重複4つと書いてあるが実際は重複とは関係なくこのマクロが実行されるたびに、列方向へ転記するのではないのか   これはどういうことかと言うと、   ID番号2005があり、今月のデータから転記され   次回の処理(来月のデータ)でまた、2005が発生していた場合など。 (3)と(4)は関係あり 以上。  

Rin-u_u
質問者

補足

ありがとうございます。 まず、 (1)コードは集計データに書きます。 (2)この部分は今まだ作成中なのですが、 Dim mb As Workbook, wb As Workbook Dim myfdr As String, fname As String, n As Integer Dim objFSO Dim objFOL Dim objWK Set mb = ThisWorkbook 'このブック(集計)をmbとする Set objFSO = CreateObject("Scripting.FileSystemObject") myfdr = ThisWorkbook.Path Set objFOL = objFSO.GetFolder(myfdr) For Each objWK In objFOL.SubFolders という風に、サブフォルダーの中から「元データファイル」を 探してきて、 For Each f In objWK.Files If fso.GetExtensionName(f.Path) = "xls" And f.Name = "元データ.xls" Then With Workbooks.Open(f.Path) というようにオープンメソッドを使う予定にしております。 (3)集計データはクリアしません。 追加の顧客IDが存在するかどうか調べて追加する&既存の顧客IDには増えた【会場名】データ(J列)のみを追加するためです。 (4)元データ 一回目   |【A】| B | C |【D】| E | F |・・・|H|I|【J】|K 3  【顧客ID】|顧客|受付日|【担当】| ・・・ |【会場名】|(見出し) 4  2005 |  ・・・・山田|  ・・・・会場A|   2006 |  ・・・・・田中|  ・・・・空白| 二回目   |【A】| B | C |【D】| E | F |・・・|H|I|【J】|K 3  【顧客ID】|顧客|受付日|【担当】|・・・|【会場名】|(見出し) 4  2005 | ・・・・山田| ・・・・会場B|←書き換えデータ    2006 ・・・・・|田中| ・・・・会場C|←書き換えデータ のとき、 集計データは 一回目 | A | B | C | D | E | F | 1 顧客ID|担当|会場名|  2005 |山田|会場A|  2006 |田中|空白| 二回目 | A | B | C | D | E | F | 1 顧客ID|担当|会場名(1)|会場名(2)  2005 |山田|会場A|会場B|  2006 |田中|空白 |会場C とする予定です。

  • end-u
  • ベストアンサー率79% (496/625)
回答No.7

Sub try()   Dim ws As Worksheet   Dim dic As Object   Dim v  As Variant '集計データ格納用配列   Dim w  As Variant '元データ格納用配列   Dim i  As Long   Dim j  As Long   Dim k  As Long   Dim x  As Long      Set ws = Workbooks("集計データ.xls").Sheets("集計")   '追加考慮し大きめに配列取る。   v = ws.Range("A1:F65536").Value   '最終データ行を取得しておく。   x = ws.Range("A65536").End(xlUp).Row      With Workbooks("元データ.xls").Sheets("データ")     w = .Range("J4", .Cells(.Rows.Count, 1).End(xlUp)).Value   End With   'Dictionaryオブジェクトに既集計キーを読み込む。同時にItemに行を記憶。   Set dic = CreateObject("scripting.dictionary")   For i = 1 To x     dic(v(i, 1)) = i   Next      For j = 1 To UBound(w)     'Existsメソッドで存在確認。それにより分岐。     If dic.exists(w(j, 1)) Then       i = dic(w(j, 1))       For k = 4 To 6         If IsEmpty(v(i, k)) Then           v(i, k) = w(j, 10)           Exit For         End If       Next     Else       x = x + 1       dic(w(j, 1)) = x       v(x, 1) = w(j, 1)       v(x, 2) = w(j, 4)       v(x, 3) = w(j, 10)     End If   Next      With ws.Cells(1).Resize(x, 6)     .ClearContents     .Value = v   End With      Set dic = Nothing   Set ws = Nothing End Sub Dictionaryオブジェクトはプロパティやメソッドがシンプルで、使い勝手が良く、 特にExistsメソッドは高速に処理できますから便利ですね。 私も好きです。 ただ今回のケースは『勉強』に適した題材かというと、ちょっと厳しいかもしれませんね。 基本についても押さえておかれたほうが良いと思います。 http://msdn.microsoft.com/ja-jp/library/cc428065.aspx http://www.geocities.jp/cbc_vbnet/Scripting/dictionary.html

Rin-u_u
質問者

お礼

ありがとうございます。私もはやくディクショナリーを使いこなせるようになりたいです。。。 本当にすごくスマートで素敵なコードに感動しています!! 更に、基本がわかるサイトまでご紹介いただいてご丁寧な対応に本当に感謝しています。

  • n-jun
  • ベストアンサー率33% (959/2873)
回答No.6

>追加変更が目的で追加というところで悩んでます。 であればANo.4での回答の通り、Findで見つからない場合の 処理でいいのでは? 私がDictionaryを回答したのは、ANo.5に記載した通りの事だと 思っていましたので。 >Dictionary勉強中なのでそのあたりを出来れば教えていただきたいのですが… 正直私も解説できるほど理解はしてないです。 他の方の回答されたコードを自分で試してみて、の手探り状態で勉強 していましたので。

  • n-jun
  • ベストアンサー率33% (959/2873)
回答No.5

>元データ.xlsというファイルのシート(データ)に >集計データ.xlsのシート(集計)に よくよく読むとBookが違ったのですね。 集計シートには既にデータがあり、追加・変更が目的なのか、 データシートのデータ追加・変更等で、その都度集計シートを白紙にして、 全て書き換えてしまっていいのか、 で違ってきますね。 私はてっきり後者だとばかり思っていたものですから、 見当違いのアドバイスだったかも? imogasiさんへ >dictionaryはVBSや.NETの概念ではないですか。エクセルVBA独自でそんな機能ありましたっけ。 私もVBSの機能だと思いますよ。 ExcelVBAの参考書では余り書いてないように見受けられ、VBScriptの参考書を 見ながら勉強してますし。

Rin-u_u
質問者

補足

追加変更が目的で追加というところで悩んでます。 Dictionary勉強中なのでそのあたりを出来れば教えていただきたいのですが… ケータイからの投稿ですのでちゃんと書きたいことがすべて書けていません すみません

  • imogasi
  • ベストアンサー率27% (4737/17069)
回答No.4

>dictionary勉強中ですが・ dictionaryはVBSや.NETの概念ではないですか。エクセルVBA独自でそんな機能ありましたっけ。私の不勉強ならすみません。 何で難しい概念・仕組みで解決する必要があるのかな。 ーー この質問をざっと見て、Findメソッドで「顧客ID」を同じものを他ファイル「集計データ」側で見つけ、そこにデータまたは「顧客ID」で集計済みデータを代入したらよいようなんだが。 こんなに長いコードにならないのではないですか。 見つからなければ最終行以下に追加。 ーー 両ファイルのレコードの並び順と重複出現の点は書いて置いてください。 集計データの顧客ID他は(前月作業とかで)暫定的に中身が出来上がっているのですか。 ーー 読者のことも考えて、読者に長いコードを解読させるコード実例は困る。今後は要点を文章で添えるとかポイントを絞る質問をお願いします。

Rin-u_u
質問者

補足

Findですね。ありがとうございます。調べます。

関連するQ&A

専門家に質問してみよう