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

Question

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

最终结果计划将“国家/地区”放入一个组合框中，选择时将用“水果”填充第二个组合框。

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

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

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  

之前的工作尝试在字典中使用字典
按评论编辑

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 行将所有表数据获取到 2D 变体数组中:

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

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

。 。 。

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

示例:nested dictionaries