[[20221201120517]]　『Dictionaryで3つ以上のKeyに対するItemの抽出方法』（Thomas）　ページの最後に飛ぶ

『Dictionaryで3つ以上のKeyに対するItemの抽出方法』（Thomas）

Dictionaryで列のKeyと行のKeyと行のKeyの3つのKeyにマッチしたItemをアウトプットしたく、下記コードを作り実行したのですが、うまくいかないです。やりたいことはSheet1にあるリストのItemをSheet2に移したいのですが、条件としてSheet2の1列目のKeyと1行目のKeyと2行目のKeyの3つのKeyにマッチしたItemのみ移したいです。列のKeyと行のKeyと行のKeyの3つのKeyは全て可変で、以前この掲示板で2つのKeyに対するDictionaryを教えて頂いて使用していたのですが、3つのKeyでの抽出方法が分からなく、念の為過去ログもひと通り確認しましたが同じ様な質問がないかと思いますので、もしよろしければどなたかご指導頂けます様お願い致します。

Sub Test()

    Dim Dic As Object
    Dim j As Long
    Dim k As Long
    Dim n As Long
    Dim lastrow As Long
    Dim lastcolumn As Long
    Dim keyR As String
    Dim keyC As String
    Dim keyW As String
    Dim ws01 As Worksheet, ws02 As Worksheet
    Set Dic = CreateObject("scripting.dictionary")
    Set ws01 = Worksheets("Sheet1")
    Set ws02 = Worksheets("Sheet2")

    lastrow = ws01.Cells(Rows.Count, 1).End(xlUp).Row
    lastcolumn = ws01.Cells(1, Columns.Count).End(xlToLeft).Column
    lastcolumn2 = ws01.Cells(2, Columns.Count).End(xlToLeft).Column
    For j = 3 To lastrow
        keyR = ws01.Cells(j, 1).Value
        If Not Dic.exists(keyR) Then
            Set Dic(keyR) = CreateObject("scripting.dictionary")
        End If
    For k = 2 To lastcolumn
        keyC = ws01.Cells(1, k).Value
    For n = 2 To lastcolumn2
        keyW = ws01.Cells(2, n).Value
        Dic(keyR)(keyC)(keyW) = ws01.Cells(j, k).Value
    Next
    Next
    Next

    lastrow = ws02.Cells(Rows.Count, 1).End(xlUp).Row
    lastcolumn = ws02.Cells(1, Columns.Count).End(xlToLeft).Column
    lastcolumn2 = ws02.Cells(2, Columns.Count).End(xlToLeft).Column
    For j = 3 To lastrow
       keyR = ws02.Cells(j, 1).Value
       If Dic.exists(keyR) Then
    For k = 2 To lastcolumn
       keyC = ws02.Cells(1, k).Value
    For n = 2 To lastcolumn2
       keyW = ws02.Cells(2, n).Value
       If Dic(keyR).exists(keyC) Then
       ws02.Cells(j, k).Value = Dic(keyR)(keyC)(keyW)
    End If
    Next
    Next
    End If
    Next
    Set Dic = Nothing
End Sub

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

[[20220105170133]] 『Dictionaryで2つ以上のKeyに対するItemの抽出方法』（Thomas）
（リンク） 2022/12/01(木) 12:43:30

 されたいことのイメージが湧きませんので、
 Sheet1のサンプルと転記後のSheet2のサンプル（両者対応したもの）を
 示してもらえますか？
  　
（γ） 2022/12/01(木) 12:56:12

 全体像が不明瞭なので、推測での回答です。想定と違っていたらスルーしてください。

 シート上の表は二次元なので、三重ループにする必要はないです。
 また、Dictionaryを入れ子にするより、３つのキーを連結して一つのキーとすれば、
 一つのDictionaryですみシンプルになります。

 下記のような感じになります。

 Sub Test()
    Dim Dic As Object
    Dim j As Long
    Dim k As Long
    Dim lastrow As Long
    Dim lastcolumn As Long
    Dim key1 As String
    Dim key2 As String
    Dim ws01 As Worksheet, ws02 As Worksheet
    Set Dic = CreateObject("scripting.dictionary")
    Set ws01 = Worksheets("Sheet1")
    Set ws02 = Worksheets("Sheet2")
    lastrow = ws01.Cells(Rows.Count, 1).End(xlUp).Row
    lastcolumn = ws01.Cells(1, Columns.Count).End(xlToLeft).Column
    For j = 3 To lastrow
        key1 = ws01.Cells(j, 1).Value
        For k = 2 To lastcolumn
            key2 = ws01.Cells(1, k).Value & ";" & ws01.Cells(2, k).Value
            Dic(key1 & ";" & key2) = ws01.Cells(j, k).Value
        Next
    Next
    lastrow = ws02.Cells(Rows.Count, 1).End(xlUp).Row
    lastcolumn = ws02.Cells(1, Columns.Count).End(xlToLeft).Column
    For j = 3 To lastrow
        key1 = ws02.Cells(j, 1).Value
        For k = 2 To lastcolumn
            key2 = ws02.Cells(1, k).Value & ";" & ws02.Cells(2, k).Value
            If Dic.exists(key1 & ";" & key2) Then
                ws02.Cells(j, k).Value = Dic(key1 & ";" & key2)
            End If
        Next
    Next
    Set Dic = Nothing
 End Sub

※修正しました。

（hatena） 2022/12/01(木) 13:42:36

ご教示頂きまして有難うございます。
頂いたコードを使ってみたところ、うまくいきました。
やりたいことを具体的ご説明すると、会社で使う見積のデータベースとそのコスト一覧をSheet1とSheet2に作りたく、Sheet1のデータベースの1列目に1から1,000位までの番号、1行目に工程名(成型・板金・洗浄・メッキ・塗装・組立等々・検査・梱包)、2行目にタクト・処理数・人件費・コストがあります。例としてB1・C1・D1・E1に成型、F1・G1・H1・J1に板金….と記載し、その下の行のB2はタクト C2は処理数 D2は人件費 E2はコストが入ります(F2はタクト G2は処理数 H2は人件費 J2はコスト…..)。Sheet2も同じく1列目に番号、1行目に工程名、2行目にタクト等が入っておりますが、必要に応じて抽出結果を変更いたします。
教えて頂きましたコードで使用可能なのですが、私が作成したコードDic(KeyR)(KeyC)(KeyW)はどこがいけないのかを今後の参考として教えて頂きたく、また同時に3重ループDic(KeyR)(KeyC)(KeyW)や2重ループDic(KeyR)(KeyC)を使ったコードも可能でしたらお教え頂けます様お願い致します。

（Thomas） 2022/12/01(木) 15:56:58

 シートは行、列の2次元ですので、Forループは行方向、列方向の2重ループになります。

 Dictionary も Dic(KeyR)(KeyC & ";" & KeyW) というように2階層になります。

 このような構成にすれば、[[20220105170133]] での私の回答の 
 Sub Test5改()
 を少し改造するだけです。

 ただ、複雑かつ重くなるだけのものをわさわざ作る気には私はなりません。
（hatena） 2022/12/01(木) 16:14:52

 すでに明確に説明されていますが、別の言い方をしてみます。

 (1)提示されたコードの以下の部分です。
         For k = 2 To lastcolumn
             keyC = ws1.Cells(1, k).Value
             For n = 2 To lastcolumn2
                 keyW = ws1.Cells(2, n).Value
                 Dic(keyR)(keyC)(keyW) = ws1.Cells(j, k).Value
             Next
         Next
    ここは、1行目と２行目の文字列を、いわば掛け算の形ですべての組み合わせを作っています。

    このとき、作成される
      B1(成型)とC2（処理数）
      B1(成型)とD2（人件費）
    等の組み合わせを作る意味が不明です。
    これらは、それぞれ
      C1(成型)とC2（処理数）
      D1(成型)とD2（人件費）
    があるのですから。

    つまりは、2次元で済むものを、わざわざ3次元にする無駄と言えるわけです。

 (2)コードの形式面からすると、   
     Dic(keyR)(keyC)はDictionaryとしての作成がされていませんから、エラーになります。

 なお、階層構造を持たせたDictionaryの利用例については、
[[20220317165423]]
 が参考になるかもしれません。（最後の発言にコードがあります）
 　
（γ） 2022/12/01(木) 23:00:44

ご説明頂きまして有難うございます。
階層構造のDictionaryについて、[[20220317165423]]や他のサイトを見ましたが、まだ理解できない部分がありますので、もう少し勉強してみたいと思います。
（Thomas） 2022/12/06(火) 10:44:38

コメント返信：

[ 一覧(最新更新順) ]

[[20221201120517]] 『Dictionaryで3つ以上のKeyに対するItemの抽出方法』（Thomas） ページの最後に飛ぶ

[[20221201120517]]　『Dictionaryで3つ以上のKeyに対するItemの抽出方法』（Thomas）　ページの最後に飛ぶ