浅谈DICTIONARY(字典)对象
浅谈DICTIONARY(字典)对象
由ExcelHome论坛 northwolves(“狼行天下”)版主 于 2007-1-5 发表
(“狼行天下”)的“博客”地址——http://blog.csdn.net/northwolves
1. Dictionary 物件(字典)
描述: 物件(字典)，用于储存資料关键字和項目对。
语法: Scripting.Dictionary
请注意
Dictionary 物件(字典)与 PERL 相关阵列全等。可以是任何型式的資料的项目被储存在阵列中。每个项目都与一个唯一的关键字相关。該关鍵字用来取出单个项目，通常是整数或字串，可以是除阵列外的任何型态。
下面的程序码举例說明了如何建立一个 Dictionary 物件(字典)：
Dim d '建立一个变数
Set d = CreateObject(Scripting.Dictionary)
d.Add "a", "Athens" '加入一些关键字和项目
d.Add "b", "Belgrade"d.Add "c", "Cairo"
2. Key 属性
描述: 在一个 Dictionary 物件中设定一个 key。
语法: object.Key(key) = newkeyKey
属性具有下列单元：
单元 描 述
object 必要引数。始終是一个 Dictionary 物件(字典)的名字。
key 必要引数。被更改的 Key。
newkey 必要引数。取代指定 key 的新。
请注意 如果在更改某个 key 时，沒有找到 key，则会出现执行阶段错误。
3. Item 属性
描述: 对 Dictionary 物件中指定的Key，设定或传回一个Item 。对于集合來說，基于指定的Key，传回一个Item。读取/写入属性。
语法: object.Item(key) [= newitem]
Item 属性具有下列单元：
| 单 元 |
描 述 |
| object |
必要引数。始終是一个集合或 Dictionary 物件(字典)的名称。 |
| key |
必要引数。与被取出或加入的项目相关的 Key 。 |
| newitem |
选择性引数。仅用于 Dictionary 物件；沒有用于集合的应用程序。如果提供的話，newitem 是与指定的 Key 相关的新值。 |
请注意 如果在改变某个 item 时，沒有找到 key，则用指定的newitem建立一个新的 key。如果在试图传回某个已存在项目时，沒有找到 key，则建立一个新 key，且其相对的项目为无。
4. Count 属性
描述：传回集合或 Dictionary 物件(字典)中的项目数。只读。
语法：object .Count object 始终是「适用于」清单中某一项目的名称。
请注意 下面的程式码举例说明了 Count 属性的使用方法：
Dim a, d, i '建立一些变数
Set d = CreateObject("Scripting.Dictionary")
d.Add "a", "Athens" '加入一些关键字和项目。
d.Add "b", "Belgrade"
d.Add "c", "Cairo"
a = d.Keys '获得关键字
For i = 0 To d.Count -1 '遍及阵列
Print a(i) '列印关键字
Next
...
5. CompareMode 属性
描述: 设定或传回 Dictionary 物件(字典)中的比较字串关键字的比较模式。
语法: object.CompareMode[ = compare]
CompareMode 属性具有下列单元：
| 单 元 |
描 述 |
| object |
必要引数。始终是一个 Dictionary 物件(字典)的名称。 |
| compare |
选择性引数。如果提供的话，compare 是一个代表比较模式的，该比较模式用于象 StrComp 这样的函数。 |
设定 compare 引数可以具有下列值：
| 常 数 |
|
描 述 |
| VbUseCompareOption |
-1 |
使用 Option Compare 陈述式的设定进行比较。 |
| vbBinaryCompare |
0 |
进行二进位比较。 |
| vbTextCompare |
1 |
进行文字比较。 |
| vbDatabaseCompare |
2 |
仅用于 Microsoft Access。进行基于您自己资料库中资讯的比较。 |
请注意 如果试图对已经包含资料的 Dictionary 物件(字典)的比较模式进行更改的话，就会出错。
CompareMode 属性所用的引数与 StrComp 函数所用的 compare 引数相同。可以用大于 2 的表示使用指定的 Locale IDs (LCID) 的比较。
dictionary方法：
1、Add 方法 (目录)
描述：加入一对相对应的关键字和項目到 Dictionary 物件(字典)。
语法：object.Add key, item
Add方法的语法有如下几个单元：
| 單元 |
描述 |
| Object |
必要引数。一个 Dictionary 物件(字典)的名字。 |
| Key |
必要引数。与所加入的项目相关的关键字。 |
| Item |
必要引数。与所加入的关键字相关的项目。 |
请注意 如果关键字已经存在，則产生一个错误。
2、Exists 方法
描述: 如果在 Dictionary 物件(字典)中指定字存在，传回 True，若不存在，传回 False。
语法: object.Exists(key) Exists 方法语法有如下几个单元：
| 單元 |
描述 |
| Object |
必要引数。始终是一个 Dictionary 物件(字典)的名字。 |
| Key |
必要引数。在 Dictionary 物件(字典)中搜寻的 Key 值。 |
3、Keys 方法
描述：传回一个阵列，該阵列包含一个 Dictionary 物件(字典)中的全部既存的的关键字。
语法：object.Keys
object始终是一个 Dictionary 物件(字典)的名字。
请注意 下面的程式码举例說明了 Keys 方法的使用。
Dim a, d, i '建立一些变数
Set d = CreateObject("Scripting.Dictionary")
d.Add "a", "Athens" '加入一些关键字和项目。
d.Add "b", "Belgrade"
d.Add "c", "Cairo"
a = d.keys '取得关键字
For i = 0 To d.Count -1 '重复阵列
Print a(i) '列印关键字
Next
...
4、Items 方法
描述：传回一个包含 Dictionary 物件(字典)中所有项目的阵列。
语法：object.Items
object始终是一个 Dictionary 物件(字典)的名字。
请注意 下面的程式码举例说明了 Items 方法的使用。:
Dim a, d, i '建立一些变数
Set d = CreateObject("Scripting.Dictionary")
d.Add "a", "Athens" '加入一些关键字和项目。
d.Add "b", "Belgrade"
d.Add "c", "Cairo"
a = d.Items '取得项目
For i = 0 To d.Count -1 '重复阵列
Print a(i) '列印项目
Next
5、Remove 方法
描述：从一个 Dictionary 物件(字典)中移除一个关键字和项目对。
语法：object.Remove(key)
Remove 方法语法有如下几个单元：
| 單元 |
描述 |
| Object |
必要引数。始终是一个 Dictionary 物件(字典)的名字。 |
| Key |
必要引数。Key 与要从 Dictionary 物件(字典)中移除的关键字和项目对相关。 |
请注意 如果指定的关键字和项目对不存在，则发生一个错误。
下面的程式码举例說明了 Remove 方法的使用
Dim a, d, i '建立一些变数
Set d = CreateObject("Scripting.Dictionary")
d.Add "a", "Athens" '加入一些关键字和项目
d.Add "b", "Belgrade"
d.Add "c", "Cairo"
...
a = d.Remove()
6、RemoveAll 方法
描述：RemoveAll 方法从 Dictionary 物件(字典)中移除所有关键字和项目对。
语法：object.RemoveAllobject始终是一个 Dictionary 物件(字典)的名字。
请注意 下面的程式码举例说明了 RemoveAll 方法的用法：
Dim a, d, i '建立一些变数
Set d = CreateObject("Scripting.Dictionary")
d.Add "a", "Athens" '加入一些关键字和项目
d.Add "b", "Belgrade"
d.Add "c", "Cairo"
...
a = d.RemoveAll
Dictinary.keys返回一维数组，因而应用比较广泛
应用实例1（顺序显示1-100）：
Sub usage()
Dim dic As Object, i As Long
Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To 100
dic.Add i, ""
Next
MsgBox Join(dic.keys, ",")
Set dic=Nothing
End Sub
应用实例2（显示1-100中含3的整数）：
Sub usage2()
Dim dic As Object, i As Long
Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To 100
dic.Add i, ""
Next
MsgBox Join(Filter(dic.keys, "3"), vbCrLf)
Set dic=Nothing
End Sub
应用实例3（WORKSHEET中A列显示1-10000）：
Sub usage3()
Dim dic As Object, i As Long, arr
Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To 10000
dic.Add i, ""
Next
arr = WorksheetFunction.Transpose(dic.keys)
[a1].Resize(UBound(arr), 1) = arr
Set dic = Nothing
End Sub
应用实例4 (WORKSHEET中A列显示1 - 10000，B列逆序显示):
Sub usage4()
Dim dic As Object, i As Long, arr
Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To 10000
dic.Add i, 10001 - i
Next
arr = WorksheetFunction.Transpose(dic.keys)
[a1].Resize(UBound(arr), 1) = arr
arr = WorksheetFunction.Transpose(dic.items)
[b1].Resize(UBound(arr), 1) = arr
Set dic = Nothing
End Sub
应用实例5 (WORKSHEET中A列显示1 - 100000中被6除余1和5 的数字):
Sub usage5()
Dim dic As Object, i As Long, arr
Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To 100000
dic.Add i & IIf(Abs(i Mod 6 - 3) = 2, "@", ""), ""
Next
arr = WorksheetFunction.Transpose(Filter(dic.keys, "@"))
[a1].Resize(UBound(arr), 1) = arr
[a:a].Replace "@", ""
Set dic = Nothing
End Sub
应用实例6 （跨表不重复值提取）:
Sub Usage6()
Application.ScreenUpdating = False ’停止屏幕刷新(也能提高程序运行速度)
Dim r As Range, arr
Worksheets("All").Select
With CreateObject("scripting.dictionary")
For Each r In Range("D3:D" & Range("A65536").End(xlUp).Row)
If Not .exists(r.Value) Then .Add r.Value, Nothing
Next
Worksheets("temp").Select
Cells.Clear
Range("a2").Resize(.Count, 1) = WorksheetFunction.Transpose(.keys)
End With
Application.ScreenUpdating = True ’重启屏幕刷新
End Sub
应用实例7 (COMBOBOX赋值):
Private Sub UserForm_Initialize()
Dim dic As Object, i As Long, arr
Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To 1000
dic.Add i, ""
Next
UserForm1.ComboBox1.List = dic.keys
Set dic = Nothing
End Sub
应用实例8 本例统计某字符串中各字符出现的频率并显示在WORKSHEET的前两行
Sub Usage8_2()
Const s As String = "在VBA中有一个数据字典即dictionary功能很好，运行速度比较快，掌握以后可以替代一些其他查找功能，现向老师请教数据字典即dictionary的基本原理是怎样的，它适合于哪些情况之下可以运用，在运用过程中应当注意哪些问题。"
Dim i As Long, temp As String, dic As Object
Set dic = CreateObject("scripting.dictionary")
For i = 1 To Len(s)
temp = Mid(s, i, 1)
If Not dic.exists(temp) Then
dic.Add temp, 1
Else
dic(temp) = dic(temp) + 1
End If
Next
[a1:a2] = WorksheetFunction.Transpose(Array("字符", "出现次数"))
[b1].Resize(1, dic.Count) = dic.keys
[b2].Resize(1, dic.Count) = dic.items
Set dic = Nothing
End Sub
应用实例9 列出一个工作簿中所有已使用的自定义函数（需要添加对VB项目的信任）
Sub UDFSOFACTIVEWORKBOOK()
Dim sh As Worksheet, r As Range, dic As Object, i As Long, temp As String, VBcomp, s() As String, UDF As String
For i = 1 To ActiveWorkbook.VBProject.VBComponents.Count
Set VBcomp = ActiveWorkbook.VBProject.VBComponents(i)
If VBcomp.Type = 1 Then temp = temp & VBCrLf & VBcomp.CodeModule.Lines(1, 65536)
Next
s = Split(temp, VBCrLf)
temp = ""
For i = 0 To UBound(s)
If s(i) Like "Function * As *" Then temp = temp & "@" & "=" & Trim(Split(Split(s(i), "(")(0), "Function")(1)) & "(" '--->All functions with or without parameters
Next
Set dic = CreateObject("scripting.dictionary")
For Each sh In Sheets
For Each r In sh.UsedRange
If r.HasFormula Then
If InStr(temp, "@" & Split(r.Formula, "(")(0)) > 0 Then
UDF = r.Formula & "udf"
Else
UDF = ""
End If
If Not dic.exists(r.Formula) Then dic.Add r.Formula, UDF
End If
Next
Next
Debug.Print "All functions used in activesheet" & VBCrLf & String(50, "-") & VBCrLf & Join(dic.keys, VBCrLf) & VBCrLf & VBCrLf '列出一个工作簿中所有函数
Debug.Print "All user define functions used in activesheet" & VBCrLf & String(50, "-") & VBCrLf & Replace(Join(Filter(dic.items, "udf"), VBCrLf), "udf", "") '列出一个工作簿中所有已使用的自定义函数
Set dic = Nothing
End Sub
应用实例10 列出Word 文档中所用的全部字体集合(在WORD VBA中使用)
Sub Usage10()
Dim myRange As Range, str_Result As String, str_Temp
With CreateObject("scripting.dictionary")
On Error Resume Next
For Each str_Temp In Application.FontNames
Set myRange = ActiveDocument.Content
With myRange.Find
.ClearFormatting
.Font.NameFarEast = str_Temp
If .Font.NameFarEast <> "" Then
If .Execute(findtext:="*", MatchWildcards:=True, Wrap:=wdFindStop, Format:=True) Then
.AddComment str_Temp, ""
End If
End If
End With
Next
MsgBox Join(.keys, vbCrLf)
End With
End Sub