如何在字典中为二维唯一值数组设置字典？

Question

我正在尝试获取独特的国家名称以及该特定国家的任何独特水果（类似于下表）。我尝试使用二维数组，但它变得复杂了。

End result with plan to put Country in one combobox that populates 2nd combobox with Fruit when selected.

我看到有人在字典中推荐字典，但我很难理解这个概念。我尝试了多种方法来设置文本字典，但我不断收到 Argument Not Optional 或 Object Required 错误。我只是语法错误还是我正在尝试做的事情存在根本问题？

编辑
万一有人尝试这样做，我意识到将文本连接在一起然后在需要时将它们拆分成一个数组要容易得多。见下文：

Dim Arr As Variant
Dim rng1 As Range
Dim rng2 As Range
Dim newRng As Range
Dim name As String
Dim text As String
Dim j As Long
Dim i As Long
Dim dcName As Scripting.Dictionary

Set dcName = New Scripting.Dictionary
Set rng1 = tbl.ListColumns("Name1").DataBodyRange
Set rng2 = tbl.ListColumns("Name5 Text").DataBodyRange
Set newRng = Range(rng1, rng2)

Arr = newRng

For i = 1 To 10 Step 2
    For j = LBound(Arr) To UBound(Arr)
        name = Arr(j, i)
        text = Arr(j, i + 1)
        If name <> vbNullString Then
            dcName(name) = dcName(name) & "|" & text
        End If
    Next j
Next i

ReDim arrSort(0 To dcName.Count - 1, 0 To 1)
For Key = 0 To dcName.Count - 1
    arrSort(Key, 0) = dcName.Keys(Key)
    arrSort(Key, 1) = dcName.Items(Key)
Next Key

For i = LBound(arrSort) To UBound(arrSort) - 1
    For j = i + 1 To UBound(arrSort)
        If UCase(arrSort(i, 0)) > UCase(arrSort(j, 0)) Then
            tempName = arrSort(j, 0)
            tempText = arrSort(j, 1)
            arrSort(j, 0) = arrSort(i, 0)
            arrSort(j, 1) = arrSort(i, 1)
            arrSort(i, 0) = tempName
            arrSort(i, 1) = tempText
        End If
    Next j
Next i

Me.cbName.List = arrSort

然后您可以将文本值拆分为一个数组并用它填充一个组合框。比我想象的要容易得多。

Private Sub cbName1_Change()
    Dim i As Integer
    Dim selName As String
    Dim arrText As Variant

    Me.cbName1Text.Clear
    selIndex = Me.cbName1.ListIndex

    text = arrSort(selIndex, 1)
    arrText = Split(text, "|")

    For i = LBound(arrText) To UBound(arrText)
        If arrText(i) <> vbNullString Then
            Me.cbName1Text.AddItem arrText(i)
        End If
    Next i

End Sub  

以前的工作尝试在字典中使用字典
按 cmets 编辑

Sub GetAbilities()
Dim Arr As Variant
Dim rng1 As Range
Dim rng2 As Range
Dim newRng As Range
Dim name As Variant
Dim text As Variant

Dim dcName As Scripting.Dictionary
Dim dcText As Scripting.Dictionary
Set dcName = New Scripting.Dictionary
Set dcText = New Scripting.Dictionary

Set rng1 = tbl.ListColumns("Name1").DataBodyRange
Set rng2 = tbl.ListColumns("Text3").DataBodyRange
Set newRng = Range(rng1, rng2)

Arr = newRng
counter = 0

For j = 1 To 10 Step 2
    For i = LBound(Arr) To UBound(Arr)
        name = Arr(i, j)
        text = Arr(i, j + 1)

        If dcName.Exists(name) Then
            If Not dcText.Exists(text) Then
                dcText.Add text, counter
            End If
        Else
        Set dcText = CreateObject("Scripting.Dictionary")
            dcName.Add name, dcText
            If text <> vbNullString Then
                dcText.Add text, counter
            End If
        End If
        counter = counter + 1
    Next i
Next j

For Each n In dcName.Keys
    For Each t In dcName.item(n).Keys
        Debug.Print n, t
    Next t
Next n

End Sub

Answer 1

您可以使用嵌套字典，但它需要更多的工作，因此您在拆分和连接字符串作为字典项的正确路径（嵌套字典对于大量数据更有效）

下面的解决方案只使用一个字典。我尝试复制您的设置，但不确定您的工作表名称和表格名称，所以我使用了 Sheet1 和 Table1，如下图所示

---

Sheet1 模块：

---

Option Explicit

Private d As Dictionary 'Private variable (global / visible to this module only) 

Private Sub SetupDictionary()   'Initialize both combo boxes --- MAIN SUB
    Set d = GetUniques(Me.ListObjects(1))
    If Not d Is Nothing Then
        Application.EnableEvents = False
            With Me.ComboBox1
                .List = d.Keys
                .ListIndex = 0
            End With
            With Me.ComboBox2
                .List = Split(d.Items(0), LINK)
                .ListIndex = 0
            End With
        Application.EnableEvents = True
    End If
End Sub

Private Sub ComboBox1_Change()
    If Not d Is Nothing Then
        With Me.ComboBox2
            .List = Split(d.Items(Me.ComboBox1.ListIndex), LINK)
            .ListIndex = 0
        End With
    End If
End Sub

---

通用模块（模块1）

---

Option Explicit

Public Const LINK = "||"   'Public (global) - visible to all modules

Public Function GetUniques(ByRef tbl As ListObject) As Dictionary
    If Not tbl Is Nothing Then
        Dim d As Dictionary, fullRng As Variant, dKey As String, dItm As String
        Dim rowIndex As Long, colIndex As Long, maxRow As Long, maxCol As Long
        fullRng = tbl.DataBodyRange 'get entire table data into a 2D variant array
        Set d = New Dictionary
        maxRow = UBound(fullRng, 1) 'dimension 1 of the 2D array    (rows)
        maxCol = UBound(fullRng, 2) 'dimension 2 of the 2D array    (columns)
        For rowIndex = 1 To maxRow                      'iterate all rows
            For colIndex = 1 To maxCol - 1 Step 2       'iterate every 2nd column
                dKey = fullRng(rowIndex, colIndex)      '-> country
                dItm = fullRng(rowIndex, colIndex + 1)  '-> fruit (next col)
                If Len(dKey) > 0 And Len(dItm) > 0 Then
                    If Not d.Exists(dKey) Then          'if key doesn't exist
                        d(dKey) = dItm                  'create 1st dictionary item
                    Else   'else check for dupes
                        If InStr(1, d(dKey), dItm, vbBinaryCompare) = 0 Then
                            d(dKey) = d(dKey) & LINK & dItm 'append next item
                        End If
                    End If
                End If
            Next colIndex
        Next rowIndex
        Dim k As Variant    'sort dictionary items for each key
        For Each k In d.Keys
            d(k) = BubbleSortStrItems(d(k), LINK)
        Next k
        Set GetUniques = d
    End If
End Function

'

Public Function BubbleSortStrItems(ByRef itms As String, ByVal sep As String) As String
    Dim vArr As Variant, i As Long, tmp As String, vArrMax As Long

    If Len(itms) > 0 And Len(sep) > 0 Then
        vArr = Split(itms, sep)
        vArrMax = UBound(vArr)
        If vArrMax > 0 Then
            For i = 0 To vArrMax - 1
                If vArr(i) > vArr(i + 1) Then
                    tmp = vArr(i)
                    vArr(i) = vArr(i + 1)
                    vArr(i + 1) = tmp
                End If
            Next i
        End If
    End If
    BubbleSortStrItems = Join(vArr, sep)
End Function

---

在GetUniques() 中，fullRng = tbl.DataBodyRange 行将所有表数据放入一个二维变量数组中：

GetUniques() 中的第一个 For 循环设置初始字典（未排序）：

第二个 For 对每个键的项目进行排序，类似于您的最终结果：

。 . .

注意：这不包括没有任何水果的国家

示例：nested dictionaries

Answer 2

这将使用嵌套字典

将以下内容放在您的用户表单代码窗格中：

Option Explicit

Dim dict As Scripting.Dictionary ' this will have 'dict' Dictionary accessible from all UserForm Subs/Functions and throughout its life

' change "ComboBox1" to your actual "Countries" combobox name and "ComboBox2" to your actual "Fruits" combobox name
Private Sub ComboBox1_Change() 
    Me.ComboBox2.List = dict(Me.ComboBox1.Value).Keys 
End Sub

Private Sub UserForm_Initialize()
    Me.ComboBox1.List = GetCountries(dict) ' fill combobox countries with countries names
End Sub

将以下内容放在任何模块中

Function GetCountries(dict As Scripting.Dictionary)
    Dim row As Range
    Dim j As Long
    Dim name As String, fruit As String

    Set dict = New Scripting.Dictionary 'change "Table1" to your actual table name and "mySheetName" to your actual table sheet name
    With Worksheets("mySheetName").ListObjects("Table1")
        For Each row In .DataBodyRange.Rows
            For j = 1 To .DataBodyRange.Columns.Count Step 2
                name = .DataBodyRange(row.row - 1, j).Value
                fruit = .DataBodyRange(row.row - 1, j + 1).Value
                If name <> "" Then
                    If Not dict.Exists(name) Then dict.Add name, New Scripting.Dictionary
                    If fruit <> "" Then dict(name)(fruit) = 1
                End If
            Next
        Next
    End With

    If dict.Count > 0 Then GetCountries = dict.Keys
End Function