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

Question

いつもお世話になっております。
現在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 · Accepted Answer

>二回目
>　　　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
※２回目実行前にはD列には何も入力しておかない事、
　３回目実行前にはE列には何も入力しておかない事、が条件です。

ついでに事前に[参照設定]する書き方にしてみました。（事前バインディング）
そうしておくと、
dic.
のあとに[プロパティ/メソッドの一覧]が表示されるVBEインテリセンス（入力支援）が効きますから
コーディングが楽になるでしょう。

onlyrom · Answer

またまたまた登場、onlyromです。

前回のダブりの例、もうひとつ場合が抜けたました。

（例１：　ＩＤと会場名セットでのダブり）

４行目＿＿２００５＿＿ＡＡ　
５行目＿＿２００５＿＿ＡＡ
６行目＿＿３３３３＿＿ＸＸ

（例２：　ＩＤのみのダブり　）

４行目＿＿２００５＿＿ＡＡ　
５行目＿＿２００５＿＿ＢＢ
６行目＿＿３３３３＿＿ＸＸ


何れにしろ、エラーというものは入力時点でチェックされるものあり、
また、今回の目的は「Dictionaryオブジェクトの理解」ですので、
エラーチェックという余計なコードを増やすのは、その妨げになると考えます。
よって、上記、例１、２とも正しいデータとして扱います。

　
●テストデータを以下のように作成して実行してください。

（１）元データ.xlsも集計データ.xlsもそれぞれ新しいブックを作成する
（２）本データの一部コピーして、データシートを作成する
（３）集計データには、（２）で作成したデータの最後のデータのＩＤは入れないで新規にしておく
（４）１回実行したあと、同じデータの最後に、新ＩＤのデータを入れ２回目を実行する

このようにすれば上手くいったかどうかの判断がし易いでしょう。

'--------------------------------------------------　
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さんのいう条件のもとで試してください。
スキルアップのためにきっと役立つはずです。

以上。

onlyrom · Answer

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

end-u · Answer

難解だとは思いますが、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セルの項目名が一致していれば
うまくいくはずです。
#うまくいかなくても、これは蛇足の参考コードなのであまり気にしないでください。

それではこの辺で。がんばってください。

onlyrom · Answer

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

onlyrom · Answer

再度の登場、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
'-----------------------------------------------------　

●重要　、について
集計シートにないＩＤは、集計シートの最後に追加するのですが、
さらに、そのＩＤが重複もしてる場合も想定しているため。
　
尚、上記コードはわざとオブジェクト変数は使ってありませんが
実際は、Select,Activateメソッドなど使用しないように
オブジェクト変数を使う方がベターでしょう。

それから、元データ.xlsはThisworkbookのPathから開いています。
　
以上。

onlyrom · Answer

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

end-u · Answer

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

n-jun · Answer

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

n-jun · Answer

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

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

>二回目

またまたまた登場、onlyromです。

またまた登場、onlyromです。

この回答への補足

難解だとは思いますが、Dictionaryオブジェクトを使わない別解法を。

あちゃーーー、

この回答への補足

再度の登場、onlyromです。

質問、補足など読んでいくといくつか重要な点が抜けてます。

この回答への補足

Sub try()

>追加変更が目的で追加というところで悩んでます。

>元データ.xlsというファイルのシート（データ）に

この回答への補足

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング