How to set up a dictionary in a dictionary for a 2D array of unique values?

Question

I am trying to get unique country names along with any unique Fruits for this particular country (like the table below). I tried using a 2D array, but it got complicated.

The end result with the plan is to put the country in one combo box, which fills the 2nd combo box with Fruit when selected.

I saw someone recommend a dictionary in a dictionary, but it's hard for me to understand the concept. I tried several ways to set up a text dictionary, but I keep getting an error Argument Not Optionalor Object Required. Am I just getting the syntax wrong or is there a fundamental problem with what I'm trying to do?

Edit
, - , , , , . . :

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

:

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

Answer 2

, , ( ).

. , , 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 :

For GetUniques() (unsorted):

, :

.,

. - .

: