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

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

　

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

Dictionaryで行のKeyと列のKeyの2つKeyにマッチしたItemをアウトプットしたく、下記コードを作り実行したのですが、うまくいかないです。やりたいことはSheet1にあるリストのItemをSheet2に移したいのですが、条件としてSheet2の行のKeyと列のKeyの2つKeyにマッチしたItemのみ移したいです。行のKeyと列のKeyは共に可変で、下記の様にDictionarにDictionaryを入れてみたのですがうまくいかない状況です。ネットで調べてみたのですが、1つのKeyに対するItemの抽出方法はあるのですが、2つ以上のKeyに対するItemの抽出方法が見つかりませんでした。念の為過去ログもひと通り確認しましたが同じ様な質問がないかと思いますので、もしよろしければどなたかご指導頂けます様お願い致します。

Sub Test4() 

    Dim Dic1 As Object
    Dim Dic2 As Object
    Dim i As Long
    Dim k As Long
    Dim lastrow As Long
    Dim lastcolumn As Long
    Dim keys1 As String
    Dim keys2 As String
    Dim Items1 As String
    Dim Items2 As String
    Dim ws01, ws02 As Worksheet


    Set Dic1 = CreateObject("scripting.Dictionary")
    Set Dic2 = CreateObject("scripting.Dictionary")
    Set ws01 = Worksheets("Sheet1")
    Set ws02 = Worksheets("Sheet2")


    lastrow = Cells(Rows.Count, 1).End(xlUp).Row
    lastcolumn = Cells(1, Columns.Count).End(xlToLeft).Column


    With ws01
        For i = 2 To lastrow
            For k = 2 To lastcolumn
                keys1 = ws01.Cells(1, k).Value
                Items1 = ws01.Cells(i, k).Value
                If Not Dic1.exists(keys1) Then
                Dic1.Add keys1, Items1
                End If
            Next k
        Next i


        For i = 2 To lastrow
            For k = 2 To lastcolumn
                keys2 = ws01.Cells(i, 1).Value
                If Not Dic2.exists(keys2) Then
                Dic2.Add keys2, Dic1
                End If
            Next k
        Next i
    End With


    With ws02
        For i = 2 To lastrow
            For k = 2 To lastcolumn
                ws02.Cells(i, k).Value = Dic2(Key2)
            Next k
        Next i
    End With


    Set Dic = Nothing

End Sub

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

こうでしょうか 

 keyC = ws01.Cells(1, k).Value
 keyR = ws01.Cells(j, 1).Value
 key = kwyC & vbTab & keyR
 dic(key) = ws01.Cells(i, k).Value

（マナ） 2022/01/05(水) 17:21

早速のコメント有難うございます。早速下記の様にコードを修正しましたが、エラーにはなりませんがItemの部分が空欄のままでした。まだVBA初心者でどこが問題なのかを見抜く知識が無く、もしよろしければ何が問題なのかご指導頂けますと幸いです。また最初に記載しましたDictionaryにDictionaryを入れるのは理論的には問題無いと思うのですが、どうしてうまくいかないのか今後の為に知っておきたく、併せてご教示頂けますとありがたいです。

Sub Test4() 

    Dim Dic1 As Object
    Dim i As Long
    Dim k As Long
    Dim lastrow As Long
    Dim lastcolumn As Long
    Dim keys1 As String
    Dim keys2 As String
    Dim keys3 As String
    Dim ws01, ws02 As Worksheet


    Set Dic1 = CreateObject("scripting.Dictionary")
    Set ws01 = Worksheets("Sheet1")
    Set ws02 = Worksheets("Sheet2")


    lastrow = Cells(Rows.Count, 1).End(xlUp).Row
    lastcolumn = Cells(1, Columns.Count).End(xlToLeft).Column


    With ws01
        For i = 2 To lastrow
            For k = 2 To lastcolumn
                keys1 = ws01.Cells(1, k).Value
                keys2 = ws01.Cells(i, 1).Value
                keys3 = keys1 & vbTab & keys2
                Dic1(keys3) = ws01.Cells(i, k).Value
            Next k
        Next i
    End With


    With ws02
        For i = 2 To lastrow
            For k = 2 To lastcolumn
                ws02.Cells(i, k).Value = Dic1(keys3)
            Next k
        Next i
    End With


    Set Dic = Nothing

End Sub

（Thomas） 2022/01/05(水) 19:15

これでどうなりますか 

 Sub Test4修正()
    Dim Dic1 As Object
    Dim i As Long
    Dim k As Long
    Dim lastrow As Long
    Dim lastcolumn As Long
    Dim keys1 As String
    Dim keys2 As String
    Dim keys3 As String
    Dim ws01   As Worksheet, ws02 As Worksheet


    Set Dic1 = 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 i = 2 To lastrow
        For k = 2 To lastcolumn
            keys1 = ws01.Cells(1, k).Value
            keys2 = ws01.Cells(i, 1).Value
            keys3 = keys1 & vbTab & keys2
            Dic1(keys3) = ws01.Cells(i, k).Value
        Next k
    Next i


    lastrow = ws02.Cells(Rows.Count, 1).End(xlUp).Row
    lastcolumn = ws02.Cells(1, Columns.Count).End(xlToLeft).Column
    For i = 2 To lastrow
        For k = 2 To lastcolumn
            keys1 = ws02.Cells(1, k).Value
            keys2 = ws02.Cells(i, 1).Value
            keys3 = keys1 & vbTab & keys2
            ws02.Cells(i, k).Value = Dic1(keys3)
        Next k
    Next i


    Set Dic = Nothing
 End Sub

（マナ） 2022/01/05(水) 19:31

＞DictionaryにDictionaryを入れる

こんな感じのことでしょうか 

    For j = 2 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
            dic(keyR)(keyC) = ws01.Cells(j, k).Value
        Next
    Next

（マナ） 2022/01/05(水) 19:48 

 =INDEX(Sheet1![リスト範囲]
        ,MATCH([行の検索値],Sheet1![Key行],0)
        ,MATCH([列の検索値],Sheet1![Key列],0)
 )


 　　・・・みたいな事なのでしょうか。


 とすれば、
 Dic1---[行の検索値]から[リスト範囲]の「行番号」を得る辞書
 Dic2---[列の検索値]から[リスト範囲]の「列番号」を得る辞書
 として、
 得られた「行番号」「列番号」から[リスト範囲]の「該当セル」を導き出す
 という組み方も考えられそうですよね。

（白茶） 2022/01/05(水) 19:49

再度早急なコメント頂きまして有難うございます。たったいま実行したところうまくいきました。有難うございました。またDictionaryにDictionaryのコードも下記の様に修正したのですが、うまくいきませんでした。理論的には理解しているつもりなのですが、やはりいまいち知識不足な為、自力でこれ以上の修正ができず、何度も申し訳御座いませんが、問題点をご教示頂ければありがたいです。また御指摘頂きましたリスト範囲の該当セルを導き出すコードも今後勉強しながら完成させてみたいと思います。

Sub Test5() 

    Dim Dic As Object
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim lastrow As Long
    Dim lastcolumn As Long
    Dim keys1 As String
    Dim keys2 As String
    Dim keys3 As String
    Dim keysR As String
    Dim keysC 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 = 2 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
            Dic(keyR)(keyC) = 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 = 2 To lastrow
        keyR = ws02.Cells(j, 1).Value
        If Not Dic.exists(keyR) Then
            Set Dic(keyR) = CreateObject("scripting.Dictionary")
        End If
    For k = 2 To lastcolumn
            keyC = ws02.Cells(1, k).Value
            Dic(keyR)(keyC) = ws02.Cells(j, k).Value
    Next
    Next


    Set Dic = Nothing


 End Sub

（Thomas） 2022/01/05(水) 20:32

こうです 

    lastrow = ws02.Cells(Rows.Count, 1).End(xlUp).Row
    lastcolumn = ws02.Cells(1, Columns.Count).End(xlToLeft).Column
    For j = 2 To lastrow
        keyR = ws02.Cells(j, 1).Value
        For k = 2 To lastcolumn
            keyC = ws02.Cells(1, k).Value
            ws02.Cells(j, k).Value = Dic(keyR)(keyC)
        Next
    Next

でも、入れ子にする意味はないと思いますよ。

（マナ） 2022/01/05(水) 20:53

Test4修正もそうですが
ws02がws01をシャフルしたものという想定です。
違うのなら、Dicに登録済みかどうか確認が必要。

（マナ） 2022/01/05(水) 21:05

衝突したけど、せっかく書いたので、、、 

 > またDictionaryにDictionaryのコードも下記の様に修正したのですが、うまくいきませんでした。

まず、変数が宣言と使用時で違ってます。 

 宣言
    Dim keysR As String
    Dim keysC As String


 使用時の一例
            Dic(keyR)(keyC) = ws01.Cells(j, k).Value


 モジュールの先頭に、Option Explicit を追加してコンパイルすると、間違いを指摘してくれますので習慣づけしておきましょう。


 Office TANAKA - 今さら聞けないVBA[変数って宣言しなくちゃいけないの？
http://officetanaka.net/excel/vba/beginner/06.htm


 あと、ws01のForループとws02のForループのコードが同じになってます。
どちらも格納のコードですので、出力されるはずかありません。

下記のように修正すればいいでしょう。 

 -------------------------
Sub Test5改()
    Dim Dic As Object
    Dim j As Long
    Dim k As Long
    Dim lastrow As Long
    Dim lastcolumn As Long
    Dim keyR As String
    Dim keyC 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 = 2 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
            Dic(keyR)(keyC) = 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 = 2 To lastrow
        keyR = ws02.Cells(j, 1).Value
        If Dic.exists(keyR) Then
            For k = 2 To lastcolumn
                keyC = ws02.Cells(1, k).Value
                If Dic(keyR).exists(keyC) Then
                    ws02.Cells(j, k).Value = Dic(keyR)(keyC)
                End If
            Next
        End If
    Next
    Set Dic = Nothing
End Sub
 ------------------------
（hatena） 2022/01/05(水) 21:12

 白茶さんの提案した方法をコードにしてみました。


 -----------------------
Sub Test6()
    Dim i As Long, j As Long
    Dim DicR As Object, DicC As Object
    Dim ws01   As Worksheet, ws02 As Worksheet
    Dim keyR As String, keyC As String
    Dim lastCol As Long


    Set DicR = CreateObject("scripting.Dictionary")
    Set DicC = CreateObject("scripting.Dictionary")
    Set ws01 = Worksheets("Sheet1")
    Set ws02 = Worksheets("Sheet2")


    'ws01の行のキーと行番号を格納
    For i = 2 To ws01.Cells(Rows.Count, 1).End(xlUp).Row
        DicR(ws01.Cells(i, 1).Value) = i
    Next
    'ws01の列のキーと列番号を格納
    For j = 2 To ws01.Cells(1, Columns.Count).End(xlToLeft).Column
        DicC(ws01.Cells(1, j).Value) = j
    Next


    lastCol = ws02.Cells(1, Columns.Count).End(xlToLeft).Column
    For i = 2 To ws02.Cells(1, Columns.Count).End(xlToLeft).Column
        keyR = ws02.Cells(i, 1).Value
        If DicR.exists(keyR) Then
            For j = 2 To lastCol
                keyC = ws02.Cells(1, j).Value
                If DicC.exists(keyC) Then
                    ws02.Cells(i, j).Value = ws01.Cells(DicR(keyR), DicC(keyC)).Value
                End If
            Next
        End If
    Next
    Set DicR = Nothing
    Set DicC = Nothing
End Sub
 -------------------------------
（hatena） 2022/01/05(水) 21:57
皆さん色々と教えて頂き有難う御座います。頂いたDictionaryにDictionaryを入れるコードはまだ試せていませんが、すぐに試してみて、また何かありましたらご相談させて頂きたくお願い致します。
（Thomas） 2022/01/06(木) 16:50
先程、他板でした回答が、
こちらのケースでも使えそうなので。

Dictionaryは使いません。全く別案です。
ws01データを配列に取り込んで、
ws02の並びに組み換えて転記しています。 

 Option Explicit


 Sub test()
    Dim r1 As Range, r2 As Range
    Dim gyo, retu


    Set r1 = Worksheets("Sheet1").Cells(1).CurrentRegion
    Set r1 = Intersect(r1, r1.Offset(1, 1))
    Set r2 = Worksheets("Sheet2").Cells(1).CurrentRegion
    Set r2 = Intersect(r2, r2.Offset(1, 1))


    gyo = Application.Match(r2.Columns(0), r1.Columns(0), 0)
    retu = Application.Match(r2.Rows(0), r1.Rows(0), 0)


    r2.Value = Application.Index(r1.Value, gyo, retu)
    On Error Resume Next
    r2.SpecialCells(xlCellTypeConstants, xlErrors).ClearContents


 End Sub

（マナ） 2022/01/07(金) 21:19

コメント返信：

[ 一覧(最新更新順) ]

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.