[[20220117142613]]　『1つのキーに複数の項目を保持したい』（こば）　ページの最後に飛ぶ

『1つのキーに複数の項目を保持したい』（こば）

お世話になります。以前[[20211228145727]]で質問した際にDictionaryを使ったやり方を教えて頂いたのですが、一つのキーに対して複数の項目を保持するにはどう書き換えればよろしいでしょうか。自分で調べて試してみましたが同じ回答が抽出されてしまいました。ご教授いただければ幸いです。

処理の方法↓

DBファイルと同じ階層にあるフォルダーのなかにAとBの２種類のファイルがあり、それぞれの条件に合う回答をDBファイルに転記していきます。
また、Aのアンケートにはシートが３つあり、"【参考】R2年アンケート"を除いたシートを移動して同じ処理を行います。

  _|___A____|___B____|___C____|___D____|___E____|___F___|___G___|___H___|　　
  1|商品名  |カテゴリ|地域　　|　県　　|回答1－1|回答1-2|回答2-1|回答2-2|
  2|商品A   |おもちゃ|　A市　 |北海道　|        |       |       |       |
  3|商品B   |家電　  |　B市   |北海道　|  　    | 　  　| 　    |       |     ・・・DBファイル_北海道
  4|商品C   |文具　  |　C市   |北海道　|        |　　　 |       |       |
  5|商品A   |おもちゃ|　B市   |北海道　|        |       |       |       |
  6|商品B   |家電　  |　C市   |北海道　|        |       |       |       |
  7|商品C   |文具　  |　D市   |北海道　|        |       |       |       |
  8|商品A　 |おもちゃ|　C市   |北海道　|        |       |       |       |
　　　　　　　　　　　　　・
　　　　　　　　　　　　　・
　　　　　　　　　　　　　・
 _|___A____|___B____|___C____|___D____|___E___|_　　  
 1|商品名  |カテゴリ|地域　　|回答1-2 |回答1-2| 
 2|商品A   |おもちゃ|A市　　 |　1　　 |あああ | 
 3|商品A   |おもちゃ|B市     |　3　　 |いいい |     ・・・アンケート回答ファイルA（商品名・カテゴリ・地域が合致する回答をDBに転記）                     
 4|商品A   |おもちゃ|C市     |　4　　 |えええ |
 5|商品B   |家電　  |A市  　 |　2　　 |おおお |
 6|商品B   |家電　  |B市     |　1　　 |aaa    |
 7|商品B   |家電　  |C市     |　5　　 |iii    |
 8|商品C　 |文具　　|A市     |　1　　 |eee    |
　　　　　　　　　　　　　・
　　　　　　　　　　　　　・
　　　　　　　　　　　　　・
　　　
  _|___A____|___B____|___C___|_　　
  1| 北海道 |おもちゃ|       |
  2|        |        |       | 
  3|商品名  |回答2-1 |回答2-2| 
  4|商品A   |1       | 〇    |
  5|商品B   |3       |       |    ・・・アンケート回答様式B（商品名とカテゴリと県が一致する回答を同じ商品名のDBの行に転記）　
  6|商品C   |4       | 〇    |　　　　　　　　　　　　
  7|商品D   |2       |       |
  8|商品E   |1       | 〇    |
  9|商品F   |2       |       |
 10|商品G　 |3       | 〇    |
　　　　　・
　　　　　・
　　　　　・

 Sub test()
     Dim dicA  As Object, dicB As Object
     Dim wsh As Object, p As String, cmd As String, s
    Dim i As Long, k As Long
    Dim 商品 As String, カテゴリ As String, 地域 As String, 県 As String
    Dim キー As String, 回答 As Long, 回答1 As Long, 回答2 As String
    Dim wb As Workbook, ws As Worksheet
    Dim myList
    Dim myArray
    Set dicA = CreateObject("scripting.dictionary")
    Set dicB = CreateObject("scripting.dictionary")
    Set wsh = CreateObject("wscript.shell")
    p = ThisWorkbook.Path & "\アンケート回答\"
    cmd = "cmd /c dir """ & p & "*A_アンケート*.xlsm"" /b/s"
    s = Split(wsh.exec(cmd).stdout.readall, vbCrLf)
    For i = 0 To UBound(s) - 1
        Set wb = Workbooks.Open(s(i))
        For Each ws In wb.Worksheets
            If Not ws.Name Like "*【参考】R2年アンケート*" Then
                 myList = ws.Range("A1", Range("A" & Rows.Count). _
                            End(xlUp)).Resize(, 5).Value
                For k = 2 To UBound(myList)
                    商品 = myList(k, 1)
                    カテゴリ = myList(k, 2)
                    地域 = myList(k, 3)
                    キー = 商品 & vbTab & カテゴリ & vbTab & 地域
                    回答1 = myList(k, 4)
                    回答2 = myList(k, 5)
                    myArray = Array(回答1, 回答2)

                    dicA(キー) = myArray(0)
                    dicA(キー) = myArray(1)

                     dicA(キー) = myArray

                Next
            End If
        Next
        wb.Close False
    Next
    cmd = "cmd /c dir """ & p & "*B_アンケート*.xlsm"" /b/s"
    s = Split(wsh.exec(cmd).stdout.readall, vbCrLf)
    For i = 0 To UBound(s) - 1
        Set wb = Workbooks.Open(s(i))
        Set ws = wb.Worksheets("B_アンケート結果")
        myList = ws.Range("A1", Range("A" & Rows.Count). _
                    End(xlUp)).Resize(, 3).Value
        県 = myList(1, 1)
        カテゴリ = myList(1, 2)
        For k = 4 To UBound(myList)
            商品 = myList(k, 1)
            キー = 商品 & vbTab & カテゴリ & vbTab & 県
            回答1 = myList(k, 2)
            回答2 = myList(k, 3)

            myArray = Array(回答1, 回答2)

            dicB(キー) = myArray(0)
            dicB(キー) = myArray(1)
        Next
        wb.Close False
    Next
    Set ws = ThisWorkbook.Worksheets("アンケート_DB")
    myList = ws.Range("A1", Range("A" & Rows.Count). _
                End(xlUp)).Resize(, 8).Value
    For k = 2 To UBound(myList)
        商品 = myList(k, 1)
        カテゴリ = myList(k, 2)
        地域 = myList(k, 3)
        県 = myList(k, 4)
        キー = 商品 & vbTab & カテゴリ & vbTab & 地域
        If dicA.exists(キー) Then myList(k, 5) = dicA(キー)
        If dicA.exists(キー) Then myList(k, 6) = dicA(キー)
        キー = 商品 & vbTab & カテゴリ & vbTab & 県
        If dicB.exists(キー) Then myList(k, 7) = dicB(キー)
        If dicB.exists(キー) Then myList(k, 8) = dicB(キー)
    Next

 ws.Range("A1").Resize(UBound(myList, 1), UBound(myList, 2)).Value = myList

 End Sub

＜使用 Excel：Excel2019、使用 OS：Windows10 ＞

 ＞一つのキーに対して複数の項目を保持するにはどう書き換えればよろしいでしょうか。

 案だけですが。
 Dictionaryを入れ子にします。
 dic.Add Key, CreateObject("scripting.dictionary")
 こんな感じで。

 dic(キー)(回答1-1)=1
 みたいになります。

 他アドバイスとしては、データベースの正規化を学ばれては、と感じました。
 フォーマットの統一化が図れますよ。
 https://medium-company.com/%E6%AD%A3%E8%A6%8F%E5%8C%96/

（tkit） 2022/01/17(月) 15:38

tkitさん、ご返信ありがとうございます。

入れ子にする案で試しましたら、上手く転記することが出来ました。
あとデータベースの正規化を少し勉強してみようと思います。ありがとうございました！

（こば） 2022/01/17(月) 17:44

提示されたコードを修正するなら

 ＞ myArray = Array(回答1, 回答2)
 ＞ dicA(キー) = myArray(0)
 ＞ dicA(キー) = myArray(1)
 ＞ dicA(キー) = myArray
        ↓	
    dicA(キー) = Array(回答1, 回答2)

とりだすときは、

 ＞ If dicA.exists(キー) Then myList(k, 5) = dicA(キー)
 ＞ If dicA.exists(キー) Then myList(k, 6) = dicA(キー)
        ↓
 　 If dicA.exists(キー) Then
       myList(k, 5) = dicA(キー)(0)
       myList(k, 6) = dicA(キー)(1)
 　 End IF

（マナ） 2022/01/17(月) 21:25

マナさんありがとうございます！

とても勉強になりました。
（こば） 2022/01/18(火) 15:47

コメント返信：

[ 一覧(最新更新順) ]

[[20220117142613]] 『1つのキーに複数の項目を保持したい』（こば） ページの最後に飛ぶ

[[20220117142613]]　『1つのキーに複数の項目を保持したい』（こば）　ページの最後に飛ぶ