[[20250310135043]]　『Dictionaryで抽出』（Thomas）　ページの最後に飛ぶ

『Dictionaryで抽出』（Thomas）

シート1のコストデータベースの中から、ある品番のみのコスト詳細をシート2に抽出したく、下記のようなコードを作り、コード1ではうまくいったのですが、コード2のDictionaryではうまくいきません。もしよろしければどの辺が問題何かをアドバイス頂きたくお願い致します。

<シート1>

A列目にPart No
1行目に製造工程名 (setup, press...)
2行目にその工程の処理数・時間・人件費・1個当たりのコスト

<シート2>

A2にPart No
2行目にその工程の処理数・時間・人件費・1個当たりのコスト
A列目に製造工程名 (setup, press...)

| QTY |Time |Laobr|cost | QTY |Time |Laobr|cost |

<シート2>
PartNo|

  5   | QTY |Time |Laobr|cost | 
Setup |  5  |  5  |  50 |  50 |   
Press |  5  |  5  |  50 |  50 |   
  .
  .
  .

<コード1>
Sub test()
Dim a, b, c, d As Long
Dim Dic As Object
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Set WS1 = Sheets(1)
Set WS2 = Sheets(2)
For a = 3 To WS1.Cells(Rows.Count, 1).End(xlUp).Row
For b = 2 To WS1.Cells(2, Columns.Count).End(xlToLeft).Column
For c = 2 To WS2.Cells(2, Columns.Count).End(xlToLeft).Column
For d = 3 To WS2.Cells(Rows.Count, 1).End(xlUp).Row
If WS1.Cells(a, 1) = WS2.Cells(2, 1) Then
If WS1.Cells(1, b) = WS2.Cells(d, 1) Then
If WS1.Cells(2, b) = WS2.Cells(2, c) Then
WS2.Cells(d, c) = WS1.Cells(a, b)
End If
End If
End If
Next
Next
Next
Next
End Sub

<コード2>
Sub test()

Dim a, b, c, d As Long
Dim KeyA, KeyB, KeyC, KeyD, KeyE
Dim Dic As Object
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Set WS1 = Sheets(1)
Set WS2 = Sheets(2)
Set Dic = CreateObject("Scripting.Dictionary")
For a = 3 To Cells(Rows.Count, 1).End(xlUp).Row
KeyA = WS1.Cells(a, 1).Value
Set Dic(KeyA) = CreateObject("Scripting.Dictionary")
For b = 2 To Cells(1, Columns.Count).End(xlToLeft).Column
KeyB = WS1.Cells(1, b).Value
KeyC = WS1.Cells(2, b).Value
Set Dic(KeyA)(KeyB) = CreateObject("Scripting.dictionary")
Set Dic(KeyA)(KeyB)(KeyC) = CreateObject("Scripting.dictionary")
Dic(KeyA)(KeyB)(KeyC) = WS1.Cells(a, b).Value
Next
Next

KeyA = WS2.Cells(2, 1).Value
For b = 3 To Cells(Rows.Count, 1).End(xlUp).Row
KeyB = WS2.Cells(b, 1).Value
For a = 2 To Cells(1, Columns.Count).End(xlToLeft).Column
KeyC = WS2.Cells(2, a).Value
On Error Resume Next
WS2.Cells(b, a).Value = Dic(KeyA)(KeyB)(KeyC)
On Error GoTo 0
Next
Next
End Sub

＜使用 Excel：Excel2013、使用 OS：Windows8 ＞

まずDictionaryオブジェクトに中身を追加するときはAddメソッドを使います
次に変数の宣言で変数名Dicが配列になっていないのでDic(x)は使えません

それから、Dictionaryもいいのですけどデータ抽出が目的ならばAutoFilterを使った方がいいと思います

（ささみ） 2025/03/10(月) 14:39:49

 Dictionaryを使うなら、
 Keyは文字列連結して一つのKeyとするといいでしょう。

 下記のコードで動作確認できました。

 Public Sub TestDic()
    Dim a As Long, b As Long
    Dim KeyA, KeyB, KeyC
    Dim Dic As Object
    Dim WS1 As Worksheet
    Dim WS2 As Worksheet(1)
    Set WS2 = Worksheets(2)
    Set Dic = CreateObject("Scripting.Dictionary")

    For a = 3 To WS1.Cells(Rows.Count, 1).End(xlUp).Row
        KeyA = WS1.Cells(a, 1).Value
        For b = 2 To WS1.Cells(1, Columns.Count).End(xlToLeft).Column
            KeyB = WS1.Cells(1, b).Value
            KeyC = WS1.Cells(2, b).Value
            Dic(Join(Array(KeyA, KeyB, KeyC), ";")) = WS1.Cells(a, b).Value
        Next
    Next

    KeyA = WS2.Cells(2, 1).Value
    For b = 3 To WS2.Cells(Rows.Count, 1).End(xlUp).Row
        KeyB = WS2.Cells(b, 1).Value
        For a = 2 To WS2.Cells(2, Columns.Count).End(xlToLeft).Column
            KeyC = WS2.Cells(2, a).Value
            WS2.Cells(b, a).Value = Dic(Join(Array(KeyA, KeyB, KeyC), ";"))
        Next
    Next
 End Sub

（hatena） 2025/03/10(月) 15:40:50

 ちなみに、

 Dic(Join(Array(KeyA, KeyB, KeyC), ";")) = WS1.Cells(a, b).Value

と

 Dic.Add Join(Array(KeyA, KeyB, KeyC), ";")), WS1.Cells(a, b).Value

 は動作はほぼ同じです。

 ただし、Keyに重複があるとき、前者はItemを上書きしますが、後者はエラーになります。
 後者の場合はExistsを使って存在するかどうか確認して存在しないときのみAddするようにします。

 今回はおそらく重複はないと思われますのでどちらでもお好みの方法でいいと思います。

（hatena） 2025/03/10(月) 15:48:51

 既に方向の是正が提言されていますが、
 現在のコードについてコメントします。

[[20250210140807]]

 でもコメントがありましたが、再度、同じ指摘をしておきます。

     Set Dic(KeyA)(KeyB) = CreateObject("Scripting.dictionary")
     Set Dic(KeyA)(KeyB)(KeyC) = CreateObject("Scripting.dictionary")
     Dic(KeyA)(KeyB)(KeyC) = WS1.Cells(a, b).Value
 が間違っています。
     Set Dic(KeyA)(KeyB) = CreateObject("Scripting.dictionary")
 としたのであれば、
 Dic(KeyA)(KeyB)がdictionaryなんですから
 Dic(KeyA)(KeyB)(key) = item
 とするだけで良いのです。
     Set Dic(KeyA)(KeyB)(KeyC) = CreateObject("Scripting.dictionary")
 は不要です。

 基本的な理解が欠けているので、dictionaryに振り回されている印象です。

（xyz） 2025/03/10(月) 16:07:15

みな様ご助言有難うございます。仕事終わりに頂いたコードで試してみます。
（Thomas） 2025/03/10(月) 16:32:13

 Set Dic(KeyA) = CreateObject("Scripting.Dictionary")
 のような書き方だと、KeyAに重複があったときに上書きされることに留意が必要です。

 重複が無いことを保証されているデータでなければ
 存在確認してからAddするような書き方にした方が安全です。
（´・ω・`） 2025/03/11(火) 08:51:03

 xyzさんと´・ω・`さんの助言を元に、質問のコード2を修正すると
 下記のようになりますね。

 Sub test2()
    Dim a As Long, b As Long
    Dim KeyA, KeyB, KeyC
    Dim Dic As Object
    Dim WS1 As Worksheet
    Dim WS2 As Worksheet
    Set WS1 = Worksheets(1)
    Set WS2 = Worksheets(2)
    Set Dic = CreateObject("Scripting.Dictionary")
    For a = 3 To WS1.Cells(Rows.Count, 1).End(xlUp).Row
        KeyA = WS1.Cells(a, 1).Value
        Set Dic(KeyA) = CreateObject("Scripting.Dictionary")
        For b = 2 To WS1.Cells(1, Columns.Count).End(xlToLeft).Column
            KeyB = WS1.Cells(1, b).Value
            KeyC = WS1.Cells(2, b).Value
            If Not Dic(KeyA).Exists(KeyB) Then
               Dic(KeyA).Add KeyB, CreateObject("Scripting.dictionary")
            End If
            Dic(KeyA)(KeyB)(KeyC) = WS1.Cells(a, b).Value
        Next
    Next
    KeyA = WS2.Cells(2, 1).Value
    For b = 3 To WS2.Cells(Rows.Count, 1).End(xlUp).Row
        KeyB = WS2.Cells(b, 1).Value
        For a = 2 To WS2.Cells(2, Columns.Count).End(xlToLeft).Column
            KeyC = WS2.Cells(2, a).Value
            WS2.Cells(b, a).Value = Dic(KeyA)(KeyB)(KeyC)
        Next
    Next
 End Sub

 これで私のコードと同じ結果になりました。

 私のコードはDictionaryオブジェクトは１つだけですが、
 こちらのコードだと1階層目で１個、２階層目で５個、３階層目で10個の計16個のDictionaryオブジェクト
 が生成されることになるので重い処理になりますね。

（hatena） 2025/03/12(水) 02:26:20

 質問回答履歴は以下のようです。
[[20220105170133]]　『Dictionaryで2つ以上のKeyに対するItemの抽出方法』（Thomas）
[[20221201120517]]　『Dictionaryで3つ以上のKeyに対するItemの抽出方法』（Thomas）
[[20230628184230]]　『Dictionaryで3つ以上のKeyに対するItemの抽出方法』（Thomas）
[[20250310135043]]　『Dictionaryで抽出』（Thomas）                              ←　いまここ
 改めて過去の記事を復習されるのも有益だと思います。

 コーディングの際には、
 そのdictionaryは、keyが何で、itemが何かをコードに書き入れたほうがよいと思います。
 意識して文書化することは、思考の明確化につながります。
 また、このとは将来も役立つことになるでしょう。（将来の自分は他人です）

 dictionaryを入れ子にする場合の書き方も提示されましたので、理解に努めていただきたいと思います。

 ただ、そうはいいつつも、私見を敢えて書きますと、
 現状ではdictionaryに余りこだわらないほうが良い気もします。
 原点に立ち戻って、次のようなコードで十分な気もします。

 Sub sample()
     Dim ws1     As Worksheet
     Dim ws2     As Worksheet
     Dim partNo&, process$
     Dim r1&, r2&, c&

     Set ws1 = Sheets(3)
     Set ws2 = Sheets(4)

     partNo = ws2.Cells(2, 1)
     r1 = Application.Match(partNo, ws1.Columns("A"), 0)
     For r2 = 3 To ws2.Cells(Rows.Count, "A").End(xlUp).Row
         process = ws2.Cells(r2, "A")
         c = Application.Match(process, ws1.Rows(1), 0)
         ws1.Cells(r1, c).Resize(1, 4).Copy ws2.Cells(r2, 2)
     Next
 End Sub
 (エラー対応は省略しています）
（xyz） 2025/03/12(水) 08:51:07

 今回の案件なら、dictionaryに誤打わる必要はないというxyzさんの意見に同意です。
 ほぼ同様のコードを書いていましたので、せっかくなので置いておきます。

 Sub testMatch()
    Dim r1 As Long, c1 As Long
    Dim r2 As Long, c2 As Long, c3 As Long
    Dim KeyA, KeyB, KeyC
    Dim WS1 As Worksheet
    Dim WS2 As Worksheet
    Set WS1 = Worksheets("Sheet9")
    Set WS2 = Worksheets("Sheet10")
    KeyA = WS2.Cells(2, 1).Value
    r1 = WorksheetFunction.Match(KeyA, WS1.Columns("A"), 0)
    For r2 = 3 To WS2.Cells(Rows.Count, 1).End(xlUp).Row
        KeyB = WS2.Cells(r2, 1).Value
        c1 = WorksheetFunction.Match(KeyB, WS1.Rows(1), 0)
        For c2 = 2 To WS2.Cells(2, Columns.Count).End(xlToLeft).Column
            KeyC = WS2.Cells(2, c2).Value
            c3 = WorksheetFunction.Match(KeyC, WS1.Rows(2), 0)
            WS2.Cells(r2, c2).Value = WS1.Cells(r1, c3).Value
        Next
    Next
 End Sub

 ちなみに、シート1、シート2の項目名が固定なら、 
 下記のコードでも十分ですね。

 Sub testFix()
    Dim r1 As Long
    Dim KeyA
    Dim WS1 As Worksheet
    Dim WS2 As Worksheet
    Set WS1 = Worksheets("Sheet9")
    Set WS2 = Worksheets("Sheet10")
    KeyA = WS2.Cells(2, 1).Value
    r1 = WorksheetFunction.Match(KeyA, WS1.Columns("A"), 0)
    WS2.Range("B3:E3").Value = WS1.Cells(r1, "B").Resize(, 4).Value
    WS2.Range("B4:E4").Value = WS1.Cells(r1, "F").Resize(, 4).Value
 End Sub

（hatena） 2025/03/12(水) 10:16:21

返信遅くなりました。皆さまアドバイス頂きまして有難うございます。
頂きましたコードを理解しようとネットで調べているのですが、
まだVBAの理解が浅く、皆様から頂いたコード(Application.MatchやWorksheetFunctioやResize等)を使ったことが無いので、まだ理解が追いつきませんので、これからこのようなメソッドも使っていこうと思います。

またhatena様から頂いたコードで質問させて頂きたく、
Dic(KeyA).Add KeyB, CreateObject("Scripting.dictionary")
を
Set Dic(KeyA)(KeyB) = CreateObject("Scripting.dictionary")
に変えてもうまくいきました。
私の理解ですと "Dic(KeyA).Add KeyB" と "Dic(KeyA)(KeyB)" は同じと理解しているのですが、やはりAddメソッドを使った方がいいのでしょうか?

（Thomas） 2025/03/15(土) 15:55:08

＞私の理解ですと "Dic(KeyA).Add KeyB" と "Dic(KeyA)(KeyB)" は同じと理解しているのですが、やはりAddメソッドを使った方がいいのでしょうか?

Addメソッドと代入処理の違いは、
2025/03/10(月) 15:48:51 ですでに説明していますが、
Keyに重複がある場合に動作が異なります。
Dictionary内にすでにKeyが存在している場合に、
同じKeyにItem登録しようとすると、Addメソッドはエラーになります。
代入処理の場合は、既に存在するKeyのItemをエラーなしに上書きします。

質問の最初の

 Set Dic(KeyA)(KeyB) = CreateObject("Scripting.dictionary")
 Set Dic(KeyA)(KeyB)(KeyC) = CreateObject("Scripting.dictionary")

のコードでうまくいかないのは、上のコードで、
KeyBが既に登録済みの場合、KeyBのItem(Dictionaryオブジェクト)を
新規にCreateObjectしたDictionaryで上書きしてしまいます。
そのため登録済みのDictionaryに格納されていたデータは破棄されてしまいます。

このコードを下記に書き換えると、

 Set Dic(KeyA).Add KeyB, CreateObject("Scripting.dictionary")
 Set Dic(KeyA)(KeyB)(KeyC) = CreateObject("Scripting.dictionary")

KeyBが既に登録済みの場合、上のコードでエラーが発生します。
そこで、KeyBが登録済みでない新規のKeyBのときのみ、
CreateObjectしたDictionaryを登録するようにしてエラーを回避します。

 If Not Dic(KeyA).Exists(KeyB) Then
     Dic(KeyA).Add KeyB, CreateObject("Scripting.Dictionary")
 End If
 Dic(KeyA)(KeyB)(KeyC) = WS1.Cells(a, b).Value

この場合、

 If Not Dic(KeyA).Exists(KeyB) Then

でKeyBが存在しないのを確認して新規Dictionaryを登録するようにしてます。
ここでは、KeyBが存在しないのを確認ずみなので、

 Dic(KeyA).Add KeyB, CreateObject("Scripting.Dictionary")

でも

 Set Dic(KeyA)(KeyB) = CreateObject("Scripting.Dictionary")

でも同じ動作になります。
が、動作としては、KeyBが存在しないときのみ新規Dictionaryを登録するということなので
前者のコードの方が意味を理解しやすいと思います。

なんか複雑すぎてうまく説明できていないように感じますが、
この説明で理解できたでしょうか。

どちらにしても、DictionaryのItemにさらにDictionaryを格納して階層構造にするのは、
このように複雑な動作になるので、Dictionaryの動作を完全に把握理解して設計しないと、
エラーや想定外の動作になりやすいです。

それと比べて、2025/03/10(月) 15:40:50 で提示したコード、
Keyを文字列連結して一つのKeyとするという方法は、
Dictionaryは一つですむし、シンプルで理解しやすいと思いますが、いかがでしょうか。

（hatena） 2025/03/15(土) 17:39:42

hatena様
丁寧なご説明頂きまして有難うございます。その後考えたのですが、やはりまだ私のレベルではDictionaryを完全に把握するのは難しい様です。ただ引き続きVBAは勉強していこうと思いますので、また何かりましたらご相談させて頂きます。
有難うございました。
（Thomas） 2025/03/21(金) 14:31:37

コメント返信：

[ 一覧(最新更新順) ]

[[20250310135043]] 『Dictionaryで抽出』（Thomas） ページの最後に飛ぶ

[[20250310135043]]　『Dictionaryで抽出』（Thomas）　ページの最後に飛ぶ