「中途半端な辞書になってしまう」事件 - Infomentのブログ～Excel VBA奮闘記～

先日 Excel について、ある調査を依頼されました。
【価格表シート】の商品コードに紐づく価格を、上手く転記できないというのです。
そこで確認したところ、まず、元となったマクロは過去に私が作成したものでした。
※実際のマクロから、一部エッセンスだけを抜粋。

Sub PricePosting()

    Dim Dict  As Dictionary ' Microsoft Scripting Runtime 参照設定済み
    Dim r     As Range
    Dim myRng As Range
    ' 商品のコードが入力された範囲を myRng にセット。
    Set myRng = Range("A1:A100")
    ' 商品のコードと右隣にある価格で辞書を作成。
    Set Dict = New Dictionary
    For Each r In myRng
        Dict(r.Value) = r.Offset(, 1).Value
    Next

    Call そのあとの処理

End Sub

このマクロでは、辞書を VLOOKUP関数のように用いて、価格を転記しています。
（今回の本題ではないので、詳細は省略します）。
依頼者はこれを機能拡張して、複数の価格表シートから辞書を作成していました。

Sub PricePosting()

    Dim Dict  As Dictionary ' Microsoft Scripting Runtime 参照設定済み
    Dim r     As Range
    Dim myRng As Range
    
    Dim i     As Long
    
    For i = 1 To 3
        With Sheets(i)
            ' 商品のコードが入力された範囲を myRng にセット。
            Set myRng = .Range("A1:A100")
            ' 商品のコードと右隣にある価格で辞書を作成。
            Set Dict = New Dictionary
            For Each r In myRng
                Dict(r.Value) = r.Offset(, 1).Value
            Next
        End With
    Next

    Call そのあとの処理

End Sub

※この時点で、もう、ピンと来た人も居ると思います。

「上手く転記できない」の詳細を訊き、以下のことが分かりました。

転記されるものと、されないものがある。
転記自体は、正しく行われている。

まず、以下の観点から、調査してみました。
① 価格表シートに、対応するコードと価格が無いのでは？
　　⇒　ありました。
② 価格表シートのレイアウトが、シート毎に異なるのでは？
　　⇒　価格表シートのレイアウトは全て共通でした。
③ 半角／全角の違いなど、辞書に登録した内容が微妙に違うのでは？
　　⇒　違いはありませんでした。

そこで、マクロをまじまじと眺めてみて・・・原因が分かりました。

    For i = 1 To 3
' （省略）
            Set Dict = New Dictionary
' （省略）
    Next

せっかく辞書にため込んだ情報を、ループするたび辞書を「New」することで破棄してています。これが原因でした。辞書の初期化をループの手前に出すことで、無事に解決しました。

Sub PricePosting()

    Dim Dict  As Dictionary ' Microsoft Scripting Runtime 参照設定済み
    Dim r     As Range
    Dim myRng As Range
    Dim i     As Long
    
    Set Dict = New Dictionary
    
    For i = 1 To 3
        With Sheets(i)
            ' 商品のコードが入力された範囲を myRng にセット。
            Set myRng = .Range("A1:A100")
            ' 商品のコードと右隣にある価格で辞書を作成。
            For Each r In myRng
                Dict(r.Value) = r.Offset(, 1).Value
            Next
        End With
    Next

    Call そのあとの処理

End Sub