VBAの配列の質問

Question

VBAの配列で教えてほしい事があります。
同一ブック内に２つのsheetがあります。
”集計結果”と”一時保管”です。

”一時保管”はA～D列にデータが入っています。
A列・・アイテムコード
B列・・子アイテムコード
C列・・品名
D列・・カテゴリ

"集計結果"はC列にアイテムコードが入っています。
やりたい事は
"集計結果"のA列にカテゴリ、B列に品名を入れたいです。

コードを書いてみました。

sub sample()

    Dim mydic As Object, mykey
    Dim c, myval
    Dim i As Long, n As Long
    
        n = Sheets("一時保管").Cells(Rows.Count, 1).End(xlUp).Row
    
        Set mydic = CreateObject("Scripting.Dictionary")
                       
        For i = 2 To n
            If Not mydic.exists(Sheets("一時保管").Cells(i, 1).Value) Then
                mydic.Add Sheets("一時保管").Cells(i, 1).Value, Sheets("一時保管").Cells(i, 3).Value
            End If
        Next i
        
        n = Sheets("集計結果").Cells(Rows.Count, 3).End(xlUp).Row
        
        For i = 2 To n
            Cells(i, 2).Value = mydic.Item(Cells(i, 3).Value)
        Next i
        
        Set mydic = Nothing

End sub

1列ずつであれば、上記コードで良いのですが、"集計結果"A、B列に一気に処理したいです。
コードの修正が分かりません。

教えて下さい。

Answer 1

既に解決済みですが参考情報として投稿させていただきます。

coco_bauerさんのディクショナリーを複数用意するという案もひとつの解決策ですが、参考までに他の案もご紹介させていただきます。

①ディクショナリーに参照行番号を格納する

提示いただいたコードではアイテムコードをキーに、品名を格納したディクショナリーを作成していました。
しかし今回取り出したいものは品名だけではないので、品名もカテゴリ名も引き出せるように"一時保管"シートの行番号を格納しておこう、という案です。

Sub sample()

    Dim mydic As Object, mykey
    Dim c, myval
    Dim i As Long, n As Long
    
    Sheets("集計結果").Activate
    
    n = Sheets("一時保管").Cells(Rows.Count, 1).End(xlUp).Row

    Set mydic = CreateObject("Scripting.Dictionary")

    For i = 2 To n
        If Not mydic.exists(Sheets("一時保管").Cells(i, 1).Value) Then
            mydic.Add Sheets("一時保管").Cells(i, 1).Value, i
        End If
    Next i

    n = Sheets("集計結果").Cells(Rows.Count, 3).End(xlUp).Row

    On Error Resume Next
    For i = 2 To n
        Dim lRow As Long
        lRow = mydic.Item(Cells(i, 3).Value)
        Cells(i, 1).Value = Sheets("一時保管").Cells(lRow, 4)
        Cells(i, 2).Value = Sheets("一時保管").Cells(lRow, 3)
    Next i

    Set mydic = Nothing

    
    MsgBox "Finish."
    
End Sub

②ディクショナリーではなくセル範囲から検索する

あえてディクショナリー検索にこだわりがなければ、Find関数で直接セル範囲を検索する方法もあります。
"一時保管"シートの対象範囲からFind関数で一致するセルを見つけて、見つけたセルからOffset関数で２列ないし３列右隣のセルを取得する、という内容です。

Sub sample()

    Dim lRow As Long
    Dim rngSrch As Range
    Dim rngFind As Range
    
    Dim shtR As Worksheet
    Dim shtW As Worksheet
    
    Set shtR = Sheets("一時保管")
    Set shtW = Sheets("集計結果")
    
    '検索対象範囲(一時保管シートA列)の設定
    Set rngSrch = shtR.Range(shtR.Cells(2, 1), shtR.Cells(shtR.Cells(Rows.Count, 1).End(xlUp).Row, 1))
    
    '出力シート（集計結果シート）のデータ行をループ処理
    For lRow = 2 To shtW.Cells(Rows.Count, "C").End(xlUp).Row
        '検索範囲から一致するセルを検索
         Set rngFind = rngSrch.Find(shtW.Cells(lRow, "C").Value)
        
        If rngFind Is Nothing Then
        Else
            '見つかった場合
            shtW.Cells(lRow, "A").Value = rngFind.Offset(0, 3).Value    '見つけたセルの３列右(D列)の値を出力シートA列に出力
            shtW.Cells(lRow, "B").Value = rngFind.Offset(0, 2).Value    '見つけたセルの２列右(C列)の値を出力シートB列に出力
        End If
    Next
    
    MsgBox "Finish."
    
End Sub

---

以上、別案を２つご紹介させていただきましたが、実現方法は他にもいろいろあります。

どれを採用するかは環境やメンテナンス性、個人の好みなどで決めていただければいいと思います。

参考になれば幸いです。

Comments

[cd987456]

ディクショナリーを使うと処理速度が格段に速くなり非常に便利です。
色々な回答ありがとうございます。
参考にさせて頂きます。

Answer 2

質問のコードは品名にしか対応できていないので、カテゴリも扱うように修正する必要があります。

アイテムコードと品名の対応関係は、既にDictionary mydicに登録するようになっていますから、同様にアイテムコードとカテゴリの対応関係を別のDictionaryに登録するようにしてから、それらを使って"集計結果"A、B列に順次書き込んでゆけば良いです。

Withを使ってシート名を何度も書かないようにすると、こういう感じになるでしょう

sub sample()
    '何のDictionayか判るように名前をつけました
    Dim dic_name As Object, dic_category As Object, mykey 
    Dim c, myval
    Dim i As Long, n As Long

        n = Sheets("一時保管").Cells(Rows.Count, 1).End(xlUp).Row

        Set dic_name = CreateObject("Scripting.Dictionary")
        Set dic_category = CreateObject("Scripting.Dictionary")

        with Sheets("一時保管")
        For i = 2 To n
            '品名のディクショナリに登録
            If Not dic_name.exists(.Cells(i, 1).Value) Then
                dic_name.Add .Cells(i, 1).Value, .Cells(i, 3).Value
            End If
            'カテゴリのディクショナリに登録
            If Not dic_category.exists(.Cells(i, 1).Value) Then
                dic_category.Add .Cells(i, 1).Value, .Cells(i, 4).Value
            End If
        Next i

        n = Sheets("集計結果").Cells(Rows.Count, 3).End(xlUp).Row

        with Sheets("集計結果")
        For i = 2 To n
            .Cells(i, 1).Value = dic_category.Item(Cells(i, 3).Value) 'A列
            .Cells(i, 2).Value = dic_name.Item(Cells(i, 3).Value) 'B列
        Next i
        end with

        Set dic_name = Nothing
        Set dic_category = Nothing


End sub