[[20210126231259]]　『Dictionary関数を用いた高速処理について』（テラ）　ページの最後に飛ぶ

『Dictionary関数を用いた高速処理について』（テラ）

初めまして。　初心者ですがどうかご教授お願い致します。
https://excel-ubara.com/excelvba4/EXCEL280.html

このサイトの、Dictionary関数を用いる方法を利用して作成していて
ReDim～の下のFor～Next文を改良し、Dictionaryに格納した値と検索したい値が合っていれば一致した値の行全体or複数のセルを別シートへ移したいと考えています。
If～文で判断しその後配列へ格納する方法をいくつかしてみたのですがうまくいきません・・・。
どうか、よろしくお願いします。

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

現在のコードを提示することはできませんか？

（γ） 2021/01/26(火) 23:38

編集がかぶりましたがそのまま。

＞If～文で判断しその後配列へ格納する方法をいくつかしてみたのですがうまくいきません・・・。
それぞれ、どのような方法を試して、どう上手くいかなかったのですか?

コードを提示したうえで、
　・エラーが出るならその箇所・エラー番号・エラーメッセージを、
　・エラーは出ないが、想定と違う動きになったなら、××の予定が○○になってします
のように説明されてはどうでしょうか？

（もこな２） 2021/01/26(火) 23:39

返答ありがとうございます。現在成功している所まで提示します。
Dim rng検索値 As Range
Dim rng検索範囲 As Range
Dim rng出力範囲 As Range

Set rng検索値 = Worksheets("参照").Range("D2:D112")
Set rng検索範囲 = Worksheets("記録").Range("K2:K10001")
Set rng出力範囲 = Worksheets("結果").Range("A2:U10001")

Dim i As Long
Dim ary()
Dim myDic As Object
Set myDic = CreateObject("scripting.dictionary")

For i = 1 To rng検索値.Rows.Count

    If Not myDic.Exists(rng検索値(i, 1).Value) Then
        myDic.Add rng検索値(i, 1).Value, rng検索値(i, 1).Value
    End If
Next
ReDim Preserve ary(1 To rng出力範囲.Rows.Count, 1 To 2)
For i = 1 To rng検索範囲.Rows.Count
    ary(i, 1) = myDic.Item(rng検索範囲(i, 1).Value)　'←うまくいかない場所です。
Next
rng出力範囲.Value = ary

上記のコードの場合、【結果】へ一致したセルがしっかりと出力されるのですが
同じ行の文字も出力したい形です。
試した方法は記憶位あるモノを下記に記します。(For文の後のみ書きます)
If rng出力範囲(i,1) = myDic.Item(i,1)
　　ary(i,1) = Rows(出力範囲(i,1))
エラーが出たのは覚えていますが番号覚えてません・・・。
（テラ） 2021/01/27(水) 00:24

高速化が目的だと思いますので、なるべくセル参照を減らすために、
検索値、検索範囲を配列に格納して処理するようにしてみました。

DictionaryオブジェクトのKeyに検索対象値、Itemに行番号を格納します。

検索値と一致する行のデータは行番号を元に出力配列に格納します。

 Public Sub Test()
    Dim v検索値() As Variant
    Dim v検索範囲() As Variant
    v検索値() = Worksheets("参照").Range("D2:D112").Value
    v検索範囲 = Worksheets("記録").Range("K2:AE10001").Value

    Dim ary() As Variant
    ReDim Preserve ary(1 To UBound(v検索値), 1 To UBound(v検索範囲, 2))

    Dim myDic As Object
    Set myDic = CreateObject("Scripting.Dictionary")

    Dim i As Long, j As Long, k As Long
    For i = 1 To UBound(v検索範囲)
        myDic(v検索範囲(i, 1)) = i
    Next

    For i = 1 To UBound(ary)
        ary(i, 1) = v検索値(i, 1)
        k = myDic(v検索値(i, 1))
        For j = 2 To UBound(ary, 2)
            ary(i, j) = v検索範囲(k, j)
        Next
    Next

    Worksheets("結果").Range("A2").Resize(UBound(ary), UBound(ary, 2)).Value = ary

 End Sub
（hatena） 2021/01/27(水) 04:02

hatena様、ご返答ありがとうございます。

上記の参考に参照範囲等整理してデバッグしてみたところ、
以下の場所でエラー9(インデックスが有効範囲にない)が出ます・・・。
参照範囲等元に戻しても同じでしたが、原因が分かりません。
ary(i, j) = v検索範囲(k, j)　(18行目)

（テラ） 2021/01/27(水) 12:26

検索値が見つからないとエラーになりますので、エラー対策を追加しました。

 Public Sub Test()
    Dim v検索値() As Variant
    Dim v検索範囲() As Variant
    v検索値 = Worksheets("参照").Range("D2:D112").Value
    v検索範囲 = Worksheets("記録").Range("K2:AE10001").Value

    Dim ary() As Variant
    ReDim Preserve ary(1 To UBound(v検索値), 1 To UBound(v検索範囲, 2))

    Dim myDic As Object
    Set myDic = CreateObject("scripting.dictionary")

    Dim i As Long, j As Long, k As Long
    For i = 1 To UBound(v検索範囲)
        myDic(v検索範囲(i, 1)) = i
    Next

    For i = 1 To UBound(ary)
        ary(i, 1) = v検索値(i, 1)
        If myDic.Exists(v検索値(i, 1)) Then
            k = myDic(v検索値(i, 1))
            For j = 2 To UBound(ary, 2)
                ary(i, j) = v検索範囲(k, j)
            Next
        End If
    Next

    Worksheets("結果").Range("A2").Resize(UBound(ary), UBound(ary, 2)).Value = ary

 End Sub

見つからなかった場合は、検索値のみ表示する仕様です。
（hatena） 2021/01/27(水) 12:44

hatena様、ありがとうございます。

1つ質問なのですが、Dictionaryへ格納するのを検索値の方にし
同じ文字列が複数あった場合でも検索値に合っていれば行全体を出力することは可能ですか？
自信で弄っているのですが参照元が同じで隣セルが違う数値でも全て同じになっていまして・・・。
《参考》

 For i = 1 To UBound(v検索値)
     myDic(v検索値(i, 1)) = i
 Next   
 For i = 1 To UBound(ary)    
     If myDic.Exists(v検索範囲(i, 11)) Then
         k = myDic(v検索範囲(i, 11))
         For j = 1 To UBound(ary, 2)
             ary(i, j) = v検索範囲(k, j)

（テラ） 2021/01/27(水) 15:16

検索範囲に重複があるのですね。
下記でどうでしょう。

 Public Sub Test1()
    Dim v検索値() As Variant
    Dim v検索範囲() As Variant
    v検索値 = Worksheets("参照").Range("D2:D112").Value
    v検索範囲 = Worksheets("記録").Range("K2:AE10001").Value

    Dim ary() As Variant
    ReDim Preserve ary(1 To UBound(v検索範囲), 1 To UBound(v検索範囲, 2))

    Dim myDic As Object
    Set myDic = CreateObject("scripting.dictionary")

    Dim i As Long, j As Long, k As Long
    For i = 1 To UBound(v検索値)
        myDic(v検索値(i, 1)) = i
    Next

    For i = 1 To UBound(ary)
        If myDic.Exists(v検索範囲(i, 1)) Then
            k = k + 1
            For j = 1 To UBound(ary, 2)
                ary(k, j) = v検索範囲(i, j)
            Next
        End If
    Next

    Worksheets("結果").Range("A2").Resize(k, UBound(ary, 2)).Value = ary

 End Sub
（hatena） 2021/01/27(水) 22:47

hatena様　返信が遅れまして申し訳ないです。

上記のマクロを試すとイメージ通りの動きをしてくれました！
後は実際のデータで走らせ微調整していきます。
何度も繰り返しありがとうございました。
（テラ） 2021/01/28(木) 20:01

コメント返信：

[ 一覧(最新更新順) ]

[[20210126231259]] 『Dictionary関数を用いた高速処理について』（テラ） ページの最後に飛ぶ

[[20210126231259]]　『Dictionary関数を用いた高速処理について』（テラ）　ページの最後に飛ぶ