[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『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 >
されたいことのイメージが湧きませんので、 Sheet1のサンプルと転記後のSheet2のサンプル(両者対応したもの)を 示してもらえますか? (γ) 2022/12/01(木) 12:56:12
全体像が不明瞭なので、推測での回答です。想定と違っていたらスルーしてください。
シート上の表は二次元なので、三重ループにする必要はないです。 また、Dictionaryを入れ子にするより、3つのキーを連結して一つのキーとすれば、 一つの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
(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行目と2行目の文字列を、いわば掛け算の形ですべての組み合わせを作っています。
このとき、作成される B1(成型)とC2(処理数) B1(成型)とD2(人件費) 等の組み合わせを作る意味が不明です。 これらは、それぞれ C1(成型)とC2(処理数) D1(成型)とD2(人件費) があるのですから。
つまりは、2次元で済むものを、わざわざ3次元にする無駄と言えるわけです。
(2)コードの形式面からすると、 Dic(keyR)(keyC)はDictionaryとしての作成がされていませんから、エラーになります。
なお、階層構造を持たせたDictionaryの利用例については、 [[20220317165423]] が参考になるかもしれません。(最後の発言にコードがあります) (γ) 2022/12/01(木) 23:00:44
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.