学习字典的用法。

ning84

https://mp.weixin.qq.com/s?__biz ... 66d275&scene=27



Excel中的字典（Dictionary）对大多数人来说都是个谜，即使是有些很熟悉VBA的人，可能对其都还不了解。其实，字典是一个很好的工具，运行快速，可以执行一些很好的计算。
字典的工作原理与普通字典相同，一个单词不会以相同的拼写输入两次。在字典中，键(key)是唯一的标识符，用于标记字典中的条目。只有唯一的键才能输入字典，这就打开了奇妙的可能性。字典可以快速存储和合并数据，其结果可以输出到任何地方并实时更新。
与字典相关的方法Add方法添加新的键/项目对到Dictionary对象。
Exists方法返回布尔值，表明键是否存在于Dictionary对象中。
Items方法返回Dictionary对象中所有项目的数组。
Keys方法返回Dictionary对象中所有键的数组。
Remove方法从Dictionary对象中移除指定的键/项目对。
RemoveAll方法从Dictionary对象中移除所有的键/项目对。
放入数据到字典以下是将项目放入字典的方法。基本字典条目分为两部分：键（Key）——为Dictionary对象中的现有键值设置新键值。项目（Item）——设置或返回Dictionary对象中项目的值。
因此，字典中的一个典型条目如下所示：“Key 1”,”Item 1”
Key 1为唯一键，Item 1为其关联项。对于初学者来说，令人困惑的是，该项在引用区域时获取键的值，这通常是通过数组对象完成的。然而，为了简化这个过程，这里将通过添加一个键和一个项目展示它是如何在一个非常基本的级别上工作的。
Add方法的使用使用.Add方法可以同时添加键和相对应的项目。这可以通过以下方式完成：Sub ScriptKey()    Dim d As Variant
    Set d = CreateObject("Scripting.dictionary")
    d.Add "Key1", "i1"    d.Add "Key2", "i2"    d.Add "Key3", "i3"End Sub
可以通过Debug.Print在立即窗口中打印出键/项目值对，代码如下：Sub ScriptKey()    Dim d As Variant
    Set d = CreateObject("Scripting.dictionary")
    d.Add "Key1", "i1"    d.Add "Key2", "i2"    d.Add "Key3", "i3"
    Debug.Print d.keys()(0), d.items()(0)    Debug.Print d.keys()(1), d.items()(1)    Debug.Print d.keys()(2), d.items()(2)End Sub
在立即窗口中的输出如下图1所示。键值在左侧，项目值在右侧。图1
引用“Microsoft Scripting Runtime”库要充分利用字典，最好在VBA的“引用”菜单中添加对“Microsoft Scripting Runtime”的引用。这将使你能够完全访问智能提示（IntelliSense），并允许查看可用的对象。
要添加“Microsoft Scripting Runtime”，在VBE中单击菜单“工具——引用”，在“引用”对话框中找到并勾选“Microsoft Scripting Runtime”前的复选框，如下图２所示。




统计字典中的项目数量
要统计字典中的项目数，使用下面的方法：
Sub ScriptKey()
    Dim d As Variant


    Set d = CreateObject("Scripting.dictionary")


    d.Add "Key1", "i1"
    d.Add "Key2", "i2"
    d.Add "Key3", "i3"


    MsgBox d.Count
End Sub


上面的代码将给出字典中的项目总数。


从字典中移除项目
删除字典中的项目非常简单，只需引用字典和要删除的项目，如下面的代码：
Sub ScriptKey()
    Dim d As Variant


    Set d = CreateObject("Scripting.dictionary")


    d.Add "Key1", "i1"
    d.Add "Key2", "i2"
    d.Add "Key3", "i3"


    d.Remove "Key1"
    MsgBox d.Count
End Sub


从字典中移除所有项目
删除字典中的所有项都比删除其中的一项容易，只需引用字典本身并调用RemoveAll命令。下面的代码将删除所有内容：
Sub ScriptKey()
    Dim d As Variant


    Set d = CreateObject("Scripting.dictionary")


    d.Add "Key1", "i1"
    d.Add "Key2", "i2"
    d.Add "Key3", "i3"


    d.RemoveAll
    MsgBox d.Count
End Sub


比较字典中的项目
如上所述，字典接受唯一键。
KEy1 and Key1
不相同，因此将为每个创建唯一键。


Sub ScriptKey()
    Dim d As Variant


    Set d = CreateObject("Scripting.dictionary")


    d.Add "KEy1", "i1"
    d.Add "Key2", "i2"
End Sub


使用上述方法添加新键。


如果不想这样，使用比较模式可以使大写的名称与小写文本相同。下面的代码将修复比较问题：
Sub ScriptComp()
    Dim d As New Dictionary


    Set d = CreateObject("Scripting.dictionary")
    d.CompareMode = TextCompare
    d.Add "KEy1", "i1"
    d.Add "Key1", "i2"
End Sub


会发生错误，如下图3所示。

图3


这是对Excel中字典的基本介绍，没有涉及到其全部强大的功能，但它确实是VBA内部一个令人惊叹且值得研究的工具。

liulang0808

https://club.excelhome.net/threa ... tml?_dsign=b73ad3d6
以前回帖的整理

ning84

liulang0808 发表于 2024-4-22 14:29
https://club.excelhome.net/thread-1385473-1-1.html?_dsign=b73ad3d6
以前回帖的整理

非常感谢帮助，必须学习做每一道题。



不太理解

1. Sub 按钮1_Click()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arr = Sheets("原始数据").[a1].CurrentRegion
   
4.     Application.ScreenUpdating = False
   
5.     ActiveSheet.UsedRange.ClearContents
   
6.     For j = 2 To UBound(arr)
   
7.         d(arr(j, 1)) = d(arr(j, 1)) + arr(j, 3)
   
8.     Next j
   
9.     [a1:b1] = Array("客户姓名", "消费总量")
   
10.     If d.Count > 0 Then
    
11.         [a2].Resize(d.Count) = WorksheetFunction.Transpose(d.keys)
    
12.         [b2].Resize(d.Count) = WorksheetFunction.Transpose(d.items)
    
13.     End If
    
14.     Application.ScreenUpdating = True
    
15. End Sub
    

复制代码

ning84

1. Sub 按钮1_Click()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arr = Sheets("原始数据").[a1].CurrentRegion
   
4.     Application.ScreenUpdating = False
   
5.     ActiveSheet.UsedRange.ClearContents
   
6.     For j = 2 To UBound(arr)
   
7.         d(arr(j, 1)) = d(arr(j, 1)) + arr(j, 3)
   
8.     Next j
   
9.     [a1:b1] = Array("客户姓名", "消费总量")
   
10.     If d.Count > 0 Then
    
11.         [a2].Resize(d.Count) = WorksheetFunction.Transpose(d.keys)
    
12.         [b2].Resize(d.Count) = WorksheetFunction.Transpose(d.items)
    
13.     End If
    
14.     Application.ScreenUpdating = True
    
15. End Sub
    
16. Sub ll021()
    
17.     Set d = CreateObject("scripting.dictionary")
    
18.     arr = Sheets("原始数据").[a1].CurrentRegion
    
19.     Application.ScreenUpdating = False
    
20.     ActiveSheet.UsedRange.ClearContents
    
21.     For j = 2 To UBound(arr)
    
22.         d(arr(j, 1) & "#" & arr(j, 2)) = d(arr(j, 1) & "#" & arr(j, 2)) + arr(j, 3)
    
23.     Next j
    
24.    
    
25.     If d.Count > 0 Then
    
26.         [a2].Resize(d.Count) = WorksheetFunction.Transpose(d.keys)
    
27.         [c2].Resize(d.Count) = WorksheetFunction.Transpose(d.items)
    
28.     End If
    
29.     Columns("A:A").TextToColumns Destination:=Range("A1"), OtherChar:="#"
    
30.     [a1:c1].Value = Sheets("原始数据").[a1:c1].Value
    
31.     Application.ScreenUpdating = True
    
32. End Sub
    

复制代码

图书馆的WPS有点问题。

1. Sub 按钮1_Click()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arr = Sheets("原始数据").[a1].CurrentRegion
   
4.     Application.ScreenUpdating = False
   
5.     ActiveSheet.UsedRange.ClearContents
   
6.     For j = 2 To UBound(arr)
   
7.         d(arr(j, 1)) = d(arr(j, 1)) + arr(j, 3)
   
8.     Next j
   
9.     [a1:b1] = Array("客户姓名", "消费总量")
   
10.     If d.Count > 0 Then
    
11.         [a2].Resize(d.Count) = WorksheetFunction.Transpose(d.keys)
    
12.         [b2].Resize(d.Count) = WorksheetFunction.Transpose(d.items)
    
13.     End If
    
14.     Application.ScreenUpdating = True
    
15. End Sub
    
16. Sub ll021()
    
17.     Set d = CreateObject("scripting.dictionary")
    
18.     arr = Sheets("原始数据").[a1].CurrentRegion
    
19.     Application.ScreenUpdating = False
    
20.     ActiveSheet.UsedRange.ClearContents
    
21.     For j = 2 To UBound(arr)
    
22.         d(arr(j, 1) & "#" & arr(j, 2)) = d(arr(j, 1) & "#" & arr(j, 2)) + arr(j, 3)
    
23.     Next j
    
24.    
    
25.     If d.Count > 0 Then
    
26.         [a2].Resize(d.Count) = WorksheetFunction.Transpose(d.keys)
    
27.         [c2].Resize(d.Count) = WorksheetFunction.Transpose(d.items)
    
28.     End If
    
29.     Columns("A:A").TextToColumns Destination:=Range("A1"), OtherChar:="#"
    
30.     [a1:c1].Value = Sheets("原始数据").[a1:c1].Value
    
31.     Application.ScreenUpdating = True
    
32. End Sub
    
33. ''
    
34. Sub ll022()
    
35.     Set d = CreateObject("scripting.dictionary")
    
36.     Set dnm = CreateObject("scripting.dictionary")
    
37.     Set dy = CreateObject("scripting.dictionary")
    
38.     arr = Sheets("原始数据").[a1].CurrentRegion
    
39.     Application.ScreenUpdating = False
    
40.     ActiveSheet.UsedRange.ClearContents
    
41.     For j = 2 To UBound(arr)
    
42.         d(arr(j, 1) & "#" & arr(j, 2)) = d(arr(j, 1) & "#" & arr(j, 2)) + arr(j, 3)
    
43.         dnm(arr(j, 1)) = ""
    
44.         dy(arr(j, 2)) = ""
    
45.     Next j
    
46.     Stop
    
47.     [a2].Resize(dnm.Count) = WorksheetFunction.Transpose(dnm.keys)
    
48.     [b1].Resize(1, dy.Count) = dy.keys
    
49.     [a1] = "客户姓名"
    
50.     arr = [a1].CurrentRegion
    
51.     For j = 2 To UBound(arr)
    
52.         For i = 2 To UBound(arr, 2)
    
53.             arr(j, i) = d(arr(j, 1) & "#" & arr(1, i))
    
54.         Next i
    
55.     Next j
    
56.     [a1].CurrentRegion = arr
    
57.     Application.ScreenUpdating = True
    
58. End Sub
    
59. 
    

复制代码

ning84

liulang0808 发表于 2024-4-22 14:29
https://club.excelhome.net/thread-1385473-1-1.html?_dsign=b73ad3d6
以前回帖的整理

学习Transpose(FileDict.Keys)的应用

1. Private Sub Ss()
   
2.     Dim Rng As Range, oRng As Range
   
3.         Set oRng = Selection
   
4.     Dim Str As String
   
5.     Dim Sht As Worksheet
   
6.         '''
   
7.         Set Sht = Sheet3
   
8.         Set Rng = Sht.Cells(20, "Q").CurrentRegion
   
9.         Debug.Print Rng.Address
   
10.     Dim FolderDict As Dictionary, FileDict As Dictionary
    
11.         Set FolderDict = New Dictionary
    
12.         Set FileDict = New Dictionary
    
13.         
    
14.         For ii = 1 To Rng.Rows.Count
    
15.              ''Debug.Print Rng(ii, 1).Address, Rng(ii, 1).Parent.Name
    
16.              'Str = Rng(ii, 1)
    
17.              FileDict(Rng(ii, 1)) = ""
    
18.              FolderDict(Rng(ii, 1).Value) = Rng(ii, 2).Value
    
19.         Next ii
    
20.         ''
    
21.         With Sheet1
    
22.              .Cells(10, 1).Resize(Rng.Rows.Count, 1) = WorksheetFunction.Transpose(FileDict.Keys)
    
23.              .Cells(10, 4).Resize(Rng.Rows.Count, 1) = WorksheetFunction.Transpose(FolderDict.Keys)
    
24.              .Cells(10, 5).Resize(Rng.Rows.Count, 1) = WorksheetFunction.Transpose(FolderDict.Items)
    
25.         End With
    
26.    
    
27.         Stop
    
28. End Sub
    

复制代码

ning84

VBA字典dictionary的Exists方法示例 - Excel VBA开发 - Office交流网  http://www.office-cn.net/excel-vba/987.html


学习FileDict.Exists("IMG_20240320_081650375.jpg")

1. Private Sub Ss()
   
2.     Dim Rng As Range, oRng As Range
   
3.         Set oRng = Selection
   
4.     Dim Str As String
   
5.     Dim Sht As Worksheet
   
6.         '''
   
7.         Set Sht = Sheet3
   
8.         Set Rng = Sht.Cells(20, "Q").CurrentRegion
   
9.         Debug.Print Rng.Address
   
10.     Dim FolderDict As Dictionary, FileDict As Dictionary
    
11.         Set FolderDict = New Dictionary
    
12.         Set FileDict = New Dictionary
    
13.         
    
14.         For ii = 1 To Rng.Rows.Count
    
15.              ''Debug.Print Rng(ii, 1).Address, Rng(ii, 1).Parent.Name
    
16.              'Str = Rng(ii, 1)
    
17.              FileDict(Rng(ii, 1).Value) = ""
    
18.              FolderDict(Rng(ii, 1).Value) = Rng(ii, 2).Value
    
19.         Next ii
    
20.         ''
    
21.         With Sheet1
    
22.              .Cells(10, 1).Resize(Rng.Rows.Count, 1) = WorksheetFunction.Transpose(FileDict.Keys)
    
23.              .Cells(10, 4).Resize(Rng.Rows.Count, 1) = WorksheetFunction.Transpose(FolderDict.Keys)
    
24.              .Cells(10, 5).Resize(Rng.Rows.Count, 1) = WorksheetFunction.Transpose(FolderDict.Items)
    
25.         End With
    
26.    
    
27.         Debug.Print FileDict.Exists("IMG_20240320_081650375.jpg")
    
28.         Stop
    
29.         Stop
    
30.         Stop
    
31. End Sub
    

复制代码