Question

我正在尝试获取唯一的国家/地区名称以及该特定国家/地区的任何独特水果（如下表所示）。我尝试使用2D数组，但它变得越来越复杂。

计划将Country放入一个组合框中的最终结果，该组合框在选择时用Fruit填充第二个组合框。

我看到有人在字典里面推荐一本字典，但我很难理解这个概念。我尝试了多种方法来设置文本字典，但我不断收到\bL或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

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

通用模块（Module1）

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循环设置初始字典（未排序）：

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

。。。

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

示例：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

如何在字典中为二维独特值数组设置字典？

2 个答案: