依赖字典Excel VBA [英] dependent dictionaries excel vba
问题描述
我想知道哪种方法是从一列中获取唯一值，然后再从另一列中获取先前在第一列中找到的每个值的最快方法
示例
Column A Column B
Case 1 Item A
Case 1 Item B
Case 1 Item A
Case 2 Item C
Case 2 Item C
Case 3 Item D
Case 3 Item E
Case 3 Item F
Case 3 Item D
结果应从第一列(案例1，案例2，案例3)返回三个值，然后对于案例1(项目A和项目B)返回两个值，对于案例2(项目C)返回一个值，三个值案例3(D，E，F项)
我不想使用高级筛选器或将筛选后的行复制到另一张纸上.
我尝试使用脚本字典来达到目的，但是我不太了解字典，因此我无法使用第一个字典的键(案例1，...)作为参数在第二个字典中添加项目字典(项目A，....)
理想情况下，最后，宏将为第一个字典的每个键创建一个文本框，然后为每个字典的第二个字典的每个键创建其他文本框(我使用树形视图，但使用文本框)
很明显，会有一个循环
这里是许多暂定词之一(但是，正如我所说，我对字典的了解真的很差)
Dim d As Variant, dict As Object
Dim v As Long, a As Variant
Dim vCount As Long
Dim vCount1 As Long
Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare 'default is vbbinarycompare
With Sheets("Sheet1") '<- alter to suite
a = .Range("a2", Range("a" & Rows.Count).End(xlUp)).Value
' change "a1"/ "a" to appropreate column reference
'build dictionary
For v = LBound(a, 1) To UBound(a, 1)
'overwrite method - faster (no error control)
'writes name&position as key, ID as item
'dict.Itema(v, 1)(Join(Array(vVALs(v, 2)
dict.Item(Join(Array(a(v, 1)), ChrW(8203))) = a(v, 2)
Next v
Me.ComboBox1.List = dict.Keys
Me.ComboBox2.List = dict.Values
'loop through the second table
For v = 2 To .Cells(Rows.Count, 2).End(xlUp).row
d = (Join(Array(a(v, 1))))
If dict.Exists(d) Then
vCount = dict.Item(d)
MsgBox vCount
End If
Next v
End With
如果有第三列怎么办? 例子
Column A Column B Column C
Case 1 Item A
Case 1 Item B number 1
Case 1 Item A number 1
Case 2 Item C number 2
Case 2 Item C number 1
Case 3 Item D number 3
Case 3 Item E number 1
Case 3 Item F number 1
Case 3 Item D number 2
结果应该是
Case 1
Item A number1
Item B number1
Case 2
Item C number1
number2
Case 3
Item D number2
number3
Item E number1
Item F number1
在这里，我尝试根据Zev Spitz的建议构建代码，但没有成功
Dim row As Variant
Dim dict As New Dictionary
For Each row In Sheets("Positioning").Range("h2", Range("p" &
Rows.Count).End(xlUp)).Rows
Dim caseKey As String
caseKey = row.Cells.Item(2, 1).Value
Dim innerDict As Scripting.Dictionary
If dict.Exists(caseKey) Then
Set innerDict = dict(caseKey)
Else
Set innerDict = New Scripting.Dictionary
Set dict(caseKey) = innerDict
End If
innerDict(row.Cells.Item(2, 3).Value) = 1
Dim outerKey As Variant, innerKey As Variant, inner2Key As Variant
Dim inner2Dict As Scripting.Dictionary
For Each innerKey In innerDict.Keys
Set inner2Dict = New Scripting.Dictionary
If inner2Dict.Exists(inner2Dict) Then
Set innerDict(innerKey) = inner2Dict
Else
Set inner2Dict = inner2Dict
End If
inner2Dict(row.Cells.Item(2, 8).Value) = 1
Next
Next
For Each outerKey In dict.Keys
Debug.Print outerKey
For Each innerKey In innerDict.Keys
Debug.Print vbTab, innerKey
For Each inner2Key In inner2Dict.Keys
Debug.Print vbTab, vbTab, inner2Key
Next
Next
Next
使用嵌套字典加载数据
您可以使用具有其他字典作为其值的字典:
Dim row As Variant
Dim dict As New Dictionary
For Each row In Worksheets("Sheet1").Range("A1", "B9").Rows
Dim caseKey As String
caseKey = row.Cells(1, 1).Value
Dim innerDict As Scripting.Dictionary
If dict.Exists(caseKey) Then
Set innerDict = dict(caseKey)
Else
Set innerDict = New Scripting.Dictionary
Set dict(caseKey) = innerDict
End If
innerDict(row.Cells(1, 2).Value) = 1 'an arbitrary value
Next
然后，您可以遍历外部词典中的每个键，并遍历内部词典中的每个键.例如，以下代码:
Dim outerKey As Variant, innerKey As Variant
For Each outerKey In dict.Keys
Debug.Print outerKey
For Each innerKey In dict(outerKey).Keys
Debug.Print vbTab, innerKey
Next
Next
将输出以下内容:
Case 1
Item A
Item B
Case 2
Item C
Case 3
Item D
Item E
Item F
有关如何使用字典获取唯一值集的说明，请参见此处.
>根据第一个组合框中的选择填充另一个组合框
假设您已将第一个组合框的List属性设置为字典的Keys集合:
Me.ComboBox1.List = dict.Keys
您可以处理 Change 组合框的事件，并用它用对应的内部字典的键填充第二个组合框:
Private Sub ComboBox1_Change()
If Value Is Nothing Then
Me.ComboBox2.List = Nothing
Exit Sub
End If
Me.ComboBox2.Value = Nothing
Me.ComboBox2.List = dict(Me.ComboBox1.Value).Keys
End Sub
使用SQL的唯一值
获取值的唯一组合的另一种方法可能是在Excel工作表上执行SQL语句:
SELECT DISTINCT [Column A], [Column B]
FROM [Sheet1$]
但这通常以ADO或DAO平面记录集(带有字段和行)的形式返回，而嵌套字典保留了此数据的层次性质.
完成代码隐藏
添加对 Microsoft脚本运行时的引用(工具> 参考... )
Option Explicit
Dim dict As New Dictionary
Private Sub ComboBox1_Change()
If Value Is Nothing Then
Me.ComboBox2.List = Nothing
Exit Sub
End If
Me.ComboBox2.Value = Nothing
Me.ComboBox2.List = dict(Me.ComboBox1.Value).Keys
End Sub
Private Sub UserForm_Initialize()
For Each row In Worksheets("Sheet1").Range("A1", "B9").rows
Dim caseKey As String
caseKey = row.Cells(1, 1).Value
Dim innerDict As Dictionary
If dict.Exists(caseKey) Then
Set innerDict = dict(caseKey)
Else
Set innerDict = New Dictionary
Set dict(caseKey) = innerDict
End If
innerDict(row.Cells(1, 2).Value) = 1 'an arbitrary value
Next
Me.ComboBox1.List = dict.Keys
End Sub
后面两个完整的组合框的完整代码
请注意，重复代码(大部分)已重构为两种方法:FindOrNew和HandleComboboxChange.
Option Explicit
Dim dict As New Dictionary
Private Function FindOrNew(d As Dictionary, key As String) As Dictionary
If d.Exists(key) Then
Set FindOrNew = d(key)
Else
Set FindOrNew = New Dictionary
Set d(key) = FindOrNew
End If
End Function
Private Sub HandleComboboxChange(source As ComboBox, target As ComboBox)
If source.Value Is Nothing Then
Set target.list = Nothing
Exit Sub
End If
Set target.Value = Nothing
End Sub
Private Sub ComboBox1_Change()
HandleComboboxChange ComboBox1, ComboBox2
ComboBox2.list = dict(ComboBox1.Value).Keys
End Sub
Private Sub ComboBox2_Change()
HandleComboboxChange ComboBox2, ComboBox3
ComboBox3.list = dict(ComboBox1.Value)(ComboBox2.Value).Keys
End Sub
Private Sub UserForm_Initialize()
For Each row In ActiveSheet.Range("A1", "C9").rows
Dim caseKey As String
caseKey = row.Cells(1, 1).Value
Dim itemKey As String
itemKey = rows.Cells(1, 2).Value
Dim dictLevel2 As Dictionary
Set dictLevel2 = FindOrNew(dict, caseKey)
Dim innerDict As Dictionary
Set innerDict = FindOrNew(dictLevel2, itemKey)
innerDict(row.Cells(1, 3).Value) = 1 'an arbitrary value
Next
ComboBox1.list = dict.Keys
End Sub
I’d like to know which is the quickest way to get the unique values from a column and then the unique values in another column for each of the values previously found in the first column
Example
Column A Column B
Case 1 Item A
Case 1 Item B
Case 1 Item A
Case 2 Item C
Case 2 Item C
Case 3 Item D
Case 3 Item E
Case 3 Item F
Case 3 Item D
The result should return three values from the first column (Case 1, Case 2, Case 3) and then two values for Case 1 (Item A and Item B), one value for Case 2 (Item C), three values for Case 3 (Item D, Item E, Item F)
I do not want to use an advance filter or copy filtered rows in another sheet.
I tried to reach that using scripting dictionary, but I don’t know dictionary so well, and I was not able to use the keys of the first dictionary (Case 1, …) as parameters to add the items in the second dictionary (Item A, ….)
Ideally, at the end, the macro will create one textbox for each key of the first dictionary and then for each of those creates other text boxes for each key of the second dictionary (I kind of treeview but using textboxes)
Clearly, there will be a loop
Here one of the many tentatives (but, as I said, I have really poor knowledge in dictionary)
Dim d As Variant, dict As Object
Dim v As Long, a As Variant
Dim vCount As Long
Dim vCount1 As Long
Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare 'default is vbbinarycompare
With Sheets("Sheet1") '<- alter to suite
a = .Range("a2", Range("a" & Rows.Count).End(xlUp)).Value
' change "a1"/ "a" to appropreate column reference
'build dictionary
For v = LBound(a, 1) To UBound(a, 1)
'overwrite method - faster (no error control)
'writes name&position as key, ID as item
'dict.Itema(v, 1)(Join(Array(vVALs(v, 2)
dict.Item(Join(Array(a(v, 1)), ChrW(8203))) = a(v, 2)
Next v
Me.ComboBox1.List = dict.Keys
Me.ComboBox2.List = dict.Values
'loop through the second table
For v = 2 To .Cells(Rows.Count, 2).End(xlUp).row
d = (Join(Array(a(v, 1))))
If dict.Exists(d) Then
vCount = dict.Item(d)
MsgBox vCount
End If
Next v
End With
What if there is a third column ? Example
Column A Column B Column C
Case 1 Item A
Case 1 Item B number 1
Case 1 Item A number 1
Case 2 Item C number 2
Case 2 Item C number 1
Case 3 Item D number 3
Case 3 Item E number 1
Case 3 Item F number 1
Case 3 Item D number 2
the result should be
Case 1
Item A number1
Item B number1
Case 2
Item C number1
number2
Case 3
Item D number2
number3
Item E number1
Item F number1
here the code I tried to build based on Zev Spitz suggestion, but without success
Dim row As Variant
Dim dict As New Dictionary
For Each row In Sheets("Positioning").Range("h2", Range("p" &
Rows.Count).End(xlUp)).Rows
Dim caseKey As String
caseKey = row.Cells.Item(2, 1).Value
Dim innerDict As Scripting.Dictionary
If dict.Exists(caseKey) Then
Set innerDict = dict(caseKey)
Else
Set innerDict = New Scripting.Dictionary
Set dict(caseKey) = innerDict
End If
innerDict(row.Cells.Item(2, 3).Value) = 1
Dim outerKey As Variant, innerKey As Variant, inner2Key As Variant
Dim inner2Dict As Scripting.Dictionary
For Each innerKey In innerDict.Keys
Set inner2Dict = New Scripting.Dictionary
If inner2Dict.Exists(inner2Dict) Then
Set innerDict(innerKey) = inner2Dict
Else
Set inner2Dict = inner2Dict
End If
inner2Dict(row.Cells.Item(2, 8).Value) = 1
Next
Next
For Each outerKey In dict.Keys
Debug.Print outerKey
For Each innerKey In innerDict.Keys
Debug.Print vbTab, innerKey
For Each inner2Key In inner2Dict.Keys
Debug.Print vbTab, vbTab, inner2Key
Next
Next
Next
Loading the data using nested dictionaries
You can use a dictionary which has other dictionaries as its' values:
Dim row As Variant
Dim dict As New Dictionary
For Each row In Worksheets("Sheet1").Range("A1", "B9").Rows
Dim caseKey As String
caseKey = row.Cells(1, 1).Value
Dim innerDict As Scripting.Dictionary
If dict.Exists(caseKey) Then
Set innerDict = dict(caseKey)
Else
Set innerDict = New Scripting.Dictionary
Set dict(caseKey) = innerDict
End If
innerDict(row.Cells(1, 2).Value) = 1 'an arbitrary value
Next
Then you can iterate over each key in the outer dictionary, and iterate over each key in the inner dictionary. The following code, for example:
Dim outerKey As Variant, innerKey As Variant
For Each outerKey In dict.Keys
Debug.Print outerKey
For Each innerKey In dict(outerKey).Keys
Debug.Print vbTab, innerKey
Next
Next
will output the following:
Case 1
Item A
Item B
Case 2
Item C
Case 3
Item D
Item E
Item F
For an description of how to use a dictionary to get a unique set of values, see here.
Populating another combobox based on the selection in the first combobox
Assuming you've set the List property of the first combobox to the Keys collection of the dictionary:
Me.ComboBox1.List = dict.Keys
you can handle the Change event of the combobox, and use it to fill the second combobox with the keys of the corresponding inner dictionary:
Private Sub ComboBox1_Change()
If Value Is Nothing Then
Me.ComboBox2.List = Nothing
Exit Sub
End If
Me.ComboBox2.Value = Nothing
Me.ComboBox2.List = dict(Me.ComboBox1.Value).Keys
End Sub
Unique values using SQL
Another way to get the unique combinations of values might be to execute an SQL statement on the Excel worksheet:
SELECT DISTINCT [Column A], [Column B]
FROM [Sheet1$]
but this generally comes back as an ADO or DAO flat Recordset -- with fields and rows -- while nested dictionaries preserve the hierarchical nature of this data.
Complete code-behind
Add a reference to the Microsoft Scripting Runtime (Tools > References...)
Option Explicit
Dim dict As New Dictionary
Private Sub ComboBox1_Change()
If Value Is Nothing Then
Me.ComboBox2.List = Nothing
Exit Sub
End If
Me.ComboBox2.Value = Nothing
Me.ComboBox2.List = dict(Me.ComboBox1.Value).Keys
End Sub
Private Sub UserForm_Initialize()
For Each row In Worksheets("Sheet1").Range("A1", "B9").rows
Dim caseKey As String
caseKey = row.Cells(1, 1).Value
Dim innerDict As Dictionary
If dict.Exists(caseKey) Then
Set innerDict = dict(caseKey)
Else
Set innerDict = New Dictionary
Set dict(caseKey) = innerDict
End If
innerDict(row.Cells(1, 2).Value) = 1 'an arbitrary value
Next
Me.ComboBox1.List = dict.Keys
End Sub
Complete code behind for two dependent comboboxes
Notice that the repetitious code has been (mostly) refactored into two methods: FindOrNew and HandleComboboxChange.
Option Explicit
Dim dict As New Dictionary
Private Function FindOrNew(d As Dictionary, key As String) As Dictionary
If d.Exists(key) Then
Set FindOrNew = d(key)
Else
Set FindOrNew = New Dictionary
Set d(key) = FindOrNew
End If
End Function
Private Sub HandleComboboxChange(source As ComboBox, target As ComboBox)
If source.Value Is Nothing Then
Set target.list = Nothing
Exit Sub
End If
Set target.Value = Nothing
End Sub
Private Sub ComboBox1_Change()
HandleComboboxChange ComboBox1, ComboBox2
ComboBox2.list = dict(ComboBox1.Value).Keys
End Sub
Private Sub ComboBox2_Change()
HandleComboboxChange ComboBox2, ComboBox3
ComboBox3.list = dict(ComboBox1.Value)(ComboBox2.Value).Keys
End Sub
Private Sub UserForm_Initialize()
For Each row In ActiveSheet.Range("A1", "C9").rows
Dim caseKey As String
caseKey = row.Cells(1, 1).Value
Dim itemKey As String
itemKey = rows.Cells(1, 2).Value
Dim dictLevel2 As Dictionary
Set dictLevel2 = FindOrNew(dict, caseKey)
Dim innerDict As Dictionary
Set innerDict = FindOrNew(dictLevel2, itemKey)
innerDict(row.Cells(1, 3).Value) = 1 'an arbitrary value
Next
ComboBox1.list = dict.Keys
End Sub
这篇关于依赖字典Excel VBA的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
