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

问题描述

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

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对我的工作产生了影响，现在我有了一份工作并开始尝试。知道怎么做吗？

解决方法

我实际上不知道为什么会有2个数组（1个带标题，1个带数据），但是这段代码将存储A列中的所有Index及其所有值（逗号分隔）与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

这是一个常见问题，恕我直言，这是VBA的主要缺陷，因为它不允许使用数组来填充合并或脚本化字典对象。我创建了自己的字典对象（Kvp），该字典对象确实允许使用数组填充字典对象。如果您想尝试一下，可以从here下载Kvp对象。

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

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

请尝试下一种方法。首先，您需要使用Function来接收该函数返回的字典并对其进行处理。然后，不需要两个数组。如果您坚持认为，结果可以是字典的字典，其中之一仅包含列标题...

字典键也是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,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

excel-2010 vba