使用两列创建字典并根据单元格值提取值

Question

我正在尝试构建一个如下所示的字典，并根据单元格值提取数据并显示它。使用下面的代码。我怎么没有得到预期的结果。

Sub Test()
    Dim Keys() As Variant: Keys = Range("A1:B1").Value2
    Dim Values() As Variant: Values = Range("A2:B7").Value2
    RangeToDict Keys, Values
End Sub
Function RangeToDict(Keys() As Variant, Values() As Variant) As Dictionary
    Set RangeToDict = New Dictionary
    For i = 1 To UBound(Keys)
        RangeToDict.Add Keys(i, 1), Values(i, 1)
        Debug.Print Keys(i, 1) & ", " & Values(i, 1)
    Next
End Function

我想创建一个字典，如图所示，如果我在字典中搜索 AA 值 ，我需要得到 1、2、3可用列中的值.

注意：我有将近 70k 的数据用于这本词典，希望这是最快的方法

COIVD 19 影响了我的工作，现在我得到了一个并且正在尝试我的脚。知道怎么做吗？

Answer 1

我实际上不知道你为什么有 2 个数组（1 个带有 headers，1 个带有数据）但是这段代码将存储 A 列中的所有索引及其所有值（逗号分隔）来自B 列：

Option Explicit
Sub Test()
    Dim Keys As Variant: Keys = Range("A2:B7").Value
    Dim MyKeys As Dictionary: Set MyKeys = New Dictionary
    
    Dim i As Long
    For i = 2 To UBound(Keys)
        With MyKeys
            If .Exists(Keys(i, 1)) Then
                MyKeys(Keys(i, 1)) = MyKeys(Keys(i, 1)) & "," & Keys(i, 2)
            Else
                .Add Keys(i, 1), Keys(i, 2)
            End If
        End With
    Next i
    
End Sub

Answer 2

请尝试下一种方法。使用 Function，您首先需要从函数接收返回的字典并用它做一些事情。然后，不需要两个数组。如果你坚持，结果可以是字典的字典，其中一个只包含列 headers...

字典键是列 A:A 和项目 ar 数组的唯一值：

Sub Test()
    Dim Keys() As Variant: Keys = Range("A1:B1").Value2
    Dim Values() As Variant: Values = Range("A2:B7").Value2
    Dim Dict As New Scripting.Dictionary, El As Variant
    Set Dict = RangeToDict(Keys, Values)
    
    For Each El In Dict.Keys
       Debug.Print El, Join(Dict(El), ", ")
    Next
End Sub

Function RangeToDict(Keys() As Variant, Values() As Variant) As Dictionary
    Dim Dict As New Scripting.Dictionary, i As Long. Keys() array not needed...
        For i = 1 To UBound(Values)
            If Not Dict.Exists(Values(i, 1)) Then
                Dict.Add Values(i, 1), Array(Values(i, 2))
            Else
                Dict(Values(i, 1)) = Split(Join(Dict(Values(i, 1)), ",") & "," & Values(i, 2), ",")
            End If
        Next i
    Set RangeToDict = Dict
End Function

Answer 3

这是一个常见问题，恕我直言，这是 VBA 的一个关键失败，因为它不允许使用数组填充 COllection 或 Scripting.DIctionary 对象。我创建了自己的字典对象 (Kvp)，它允许使用数组填充字典对象。如果您想尝试一下，可以从 here 下载 Kvp 对象。

使用 Kvp 字典对象，您上面的代码将变成

Dim myKvp as Kvp
Set myKvp=new Kvp
myKvp.AddByKeyFromArrays  Range("A1:B1").Value2, Range("A2:B7").Value2

使用两列创建字典并根据单元格值提取值

Creating dictionary using two columns and extract value based on cell value

vba

excel-2010