前言第一次见到字典的用法是在2003年，记得是一个关于列举闰年的帖子,代码大致如下:以下代码是计算2000年到2100年间的所有闰年：Sub diag()Dim i As IntegerWith CreateObject("scripting.dictionary")For i = 2000 To 2100If Day(DateSerial(i, 3, 0)) = 29 Then .Add i, NothingNextMsgBox Join(.keys, " ")End WithEnd Sub当时深感字典对象的神奇,所以把帮助看了又看,对它有了初步的了解，试着写了一些测试代码，总体感觉效率还可以。
由于本人水平有限，难免有纰漏之处，还请大家谅解。
定义 Dictionary 对象是 “ Scripting Runtime Library” 的一部分，最早在VBScript 中实现（SCRRUN.DLL），它将任何形式的数据的条目被存储在数组中。
每个条目都与一个唯一的关键字相关联。
该关键字用来检索单个条目，通常是整数或字符串，可以是除数组外的任何类型.Dictionary 对象的属性和说明属性说明CompareMode设定或返回键的字符串比较模式（仅用于 VBScript）Count只读。
返回 Dictionary 里的键/条目对的数量Item(key)设定或返回指定的键的条目值Key(key)设定键值以下是MSDN帮助文件内容：Key 属性描述在一个 Dictionary 对象中设置一个 key。
语法object.Key(key) = newkeyKey 属性具有下列部分：部分描述object必需的。
总是一个 Dictionary 对象的名字。
key必需的。
被更改的 Key值。
newkey必需的。
替换指定 key 的新值。
说明如果在更改某个 key 时，没有找到 key，则会出现运行时错误。
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，且其相应的条目为空。
Count 属性描述返回集合或 Dictionary 对象中的条目数。
只读。
语法object.Countobject 总是“应用于”列表中某一项的名称。
说明下面的代码举例说明了 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...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 对象的方法和说明]方法说明Add(key,item)增加键/条目对到 DictionaryExists(key)如果指定的键存在，返回 True，否则返回 FalseItems()返回一个包含 Dictionary 对象中所有条目的数组Keys()返回一个包含 Dictionary 对象中所有键的数组Remove(key)删除一个指定的键/条目对RemoveAll()删除全部键/条目对以下为MSDN帮助文件内容：Add方法(Dictionary)描述添加一对相对应的关键字和条目到 Dictionary 对象。
语法object.Add key, itemAdd方法的语法有如下几部分：部分描述Object必需的。
一个 Dictionary 对象的名字。
Key必需的。
与所添加的条目相关联的关键字。
Item必需的。
与所添加的关键字相关联的条目。
说明如果该关键字已经存在，则产生一个错误。
Exists 方法描述如果在 Dictionary 对象中指定的关键字存在，返回 True，若不存在，返回 False。
语法object.Exists(key)Exists 方法语法有如下几部分：部分描述Object必需的。
始终是一个 Dictionary 对象的名字。
Key必需的。
在 Dictionary 对象中搜索的 Key 值。
Keys方法描述返回一个数组，该数组包含一个 Dictionary 对象中的全部已有的关键字。
语法object.Keysobject始终是一个 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...Items 方法描述返回一个包含 Dictionary 对象中所有条目的数组。
语法object.Itemsobject始终是一个 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...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()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 '清除字典特别说明:Dictionary的CompareMode属性与VBA的Comparison常数是一致的: 常数值描述VbUseCompareOption-1使用Option Compare语句的设置进行比较。
VbBinaryCompare0进行二进制的比较。
VbTextCompare1进行文字的比较。
vbDatabaseCompare2用于 Microsoft Access(仅限于Windows)，进行以数据库所含信息为基础的比较。
区别:Sub macro1()Dim d As New Dictionary, s, i As Longs = [{"aa","Aa","aA"}]On Error Resume Nextd.CompareMode = BinaryCompare'二进制方式比较,即a,A是不同字符For i = 1 To 3d.Add s(i), ""NextDebug.Print Join(d.Keys, vbCrLf); vbCrLf; "d.Count=" & d.CountEnd Sub返回:aaAaaAd.Count=3Sub macro2()Dim d As New Dictionary, s, i As Longs = [{"aa","Aa","aA"}]On Error Resume Nextd.CompareMode = TextCompare'文本方式比较,即a,A是相同字符For i = 1 To 3d.Add s(i), ""NextDebug.Print Join(d.Keys, vbCrLf); vbCrLf; "d.Count=" & d.CountEnd Sub返回:aad.Count=1另: 以下函数也具有此属性,应用时需要注意:InStr 函数返回 Variant (Long)，指定一字符串在另一字符串中最先出现的位置。
语法 InStr([start, ]string1, string2[, compare])InStrRev函数描述返回一个字符串在另一个字符串中出现的位置，从字符串的末尾算起。
语法InstrRev(stringcheck, stringmatch[, start[, compare]])StrComp 函数返回 Variant (Integer)，为字符串比较的结果。
语法StrComp(string1, string2[, compare])Replace函数描述返回一个字符串，该字符串中指定的子字符串已被替换成另一子字符串，并且替换发生的次数也是指定的。
语法Replace(expression, find, replace[, start[, count[, compare]]])Filter函数描述返回一个下标从零开始的数组，该数组包含基于指定筛选条件的一个字符串数组的子集。
语法Filter(sourcesrray, match[, include[, compare]])Split函数描述返回一个下标从零开始的一维数组，它包含指定数目的子字符串。
语法Split(expression[, delimiter[, limit[, compare]]])如果模块级别使用了Option Compare {Binary | Text | Database}声明,Dictionary对象与以上列举函数将默认使用此格式.常数值描述VbUseCompareOption-1使用Option Compare语句的设置进行比较。
VbBinaryCompare0进行二进制的比较。
VbTextCompare1进行文字的比较。
vbDatabaseCompare2用于 Microsoft Access(仅限于Windows)，进行以数据库所含信息为基础的比较。
区别:Sub macro1()Dim d As New Dictionary, s, i As Longs = [{"aa","Aa","aA"}]On Error Resume Nextd.CompareMode = BinaryCompare'二进制方式比较,即a,A是不同字符For i = 1 To 3d.Add s(i), ""NextDebug.Print Join(d.Keys, vbCrLf); vbCrLf; "d.Count=" & d.CountEnd Sub返回:aaAaaAd.Count=3Sub macro2()Dim d As New Dictionary, s, i As Longs = [{"aa","Aa","aA"}]On Error Resume Nextd.CompareMode = TextCompare'文本方式比较,即a,A是相同字符For i = 1 To 3d.Add s(i), ""NextDebug.Print Join(d.Keys, vbCrLf); vbCrLf; "d.Count=" & d.CountEnd Sub返回:aad.Count=1另: 以下函数也具有此属性,应用时需要注意:InStr 函数返回 Variant (Long)，指定一字符串在另一字符串中最先出现的位置。
语法 InStr([start, ]string1, string2[, compare])InStrRev函数描述返回一个字符串在另一个字符串中出现的位置，从字符串的末尾算起。
语法InstrRev(stringcheck, stringmatch[, start[, compare]])StrComp 函数返回 Variant (Integer)，为字符串比较的结果。
语法StrComp(string1, string2[, compare])Replace函数描述返回一个字符串，该字符串中指定的子字符串已被替换成另一子字符串，并且替换发生的次数也是指定的。
语法Replace(expression, find, replace[, start[, count[, compare]]])Filter函数描述返回一个下标从零开始的数组，该数组包含基于指定筛选条件的一个字符串数组的子集。
语法Filter(sourcesrray, match[, include[, compare]])Split函数描述返回一个下标从零开始的一维数组，它包含指定数目的子字符串。
语法Split(expression[, delimiter[, limit[, compare]]])如果模块级别使用了Option Compare {Binary | Text | Database}声明,Dictionary对象与以上列举函数将默认使用此格式.Dictionary属性和方法的亮点(与Collection对象相比):1.key属性可随时更改:If dic.Exists(OldKey) Then dic.Key(OldKey) = NewKey2.item属性可随时更改:If dic.Exists(OldKey) Then dic.Item(OldKey) = NewItem3.Keys方法可得到一个下界为0的一维数组:Dim ss=dic.keys4.items方法也可得到一个下界为0的一维数组:Dim ss=dic.Items5. Remove 方法可直接删除Dictionary对象的某一个元素,对于VB的一维数组来说,省去了不少编码的烦恼6. Removeall方法可直接删除Dictionary对象的全部元素7.对于使用Keys和items方法得到的数组,可以使用VBA的数组的全部技巧进行处理,如Filter(),Join()函数及工作表函数Transpose(),Max(),Min(),Large()等的使用.8.Count属性为Dictionary数组与EXCEL工作表的相互赋值提供了方便.9.键值的唯一性使得Dictionary对象在统计"不重复"方面的问题得心应手,而item属性可更改更使得Dictionary对象在数据汇总上大显身手.10.VBA的一些控件如listbox,combobox,单元格的数据有效性,自定义序列及图表的序列,xvalue属性等也与数组有一定的联系,使得Dictionary对象也有用武之地.后面的例子将对以上所介绍的内容进行演示.Dictionary对象的引用:与其他DLL一样,我们常用以下两种方法引用Dictionary对象.方法1:在工具-->引用菜单中,选择Scripting Runtime Library: 然后在模块中按以下方式引用:Dim dic As New Dictionary或者Dim dic2 As New Scripting.Dictionary方法2:使用CreateObject方法,如:Dim dic As ObjectSet dic=CreateObject("scripting.dictionary")更多数情况下,我们可以忽略变量的定义,直接使用其属性和方法,如开头的例子:Dim i As IntegerWith CreateObject("scripting.dictionary")For i = 2000 To 2100If Day(DateSerial(i, 3, 0)) = 29 Then .Add i, NothingNextMsgBox Join(.keys, " ")End With浅谈DICTIONARY(字典)对象的一些示例应用实例1（顺序显示1-100）：Sub usage()Dim dic As Object, i As LongSet dic = CreateObject("Scripting.Dictionary")For i = 1 To 100dic.Add i, ""NextMsgBox Join(dic.keys, ",")Set dic=NothingEnd Sub应用实例2（显示1-100中含3的整数）：Sub usage2()Dim dic As Object, i As LongSet dic = CreateObject("Scripting.Dictionary")For i = 1 To 100dic.Add i, ""NextMsgBox Join(Filter(dic.keys, "3"), vbCrLf)Set dic=NothingEnd Sub应用实例3（WORKSHEET中A列显示1-10000）：Sub usage3()Dim dic As Object, i As Long, arrSet dic = CreateObject("Scripting.Dictionary")For i = 1 To 10000dic.Add i, ""Nextarr = WorksheetFunction.Transpose(dic.keys)[a1].Resize(UBound(arr), 1) = arrSet dic = NothingEnd Sub应用实例4 (WORKSHEET中A列显示1 - 10000，B列逆序显示):Sub usage4()Dim dic As Object, i As Long, arrSet dic = CreateObject("Scripting.Dictionary")For i = 1 To 10000dic.Add i, 10001 - iNextarr = WorksheetFunction.Transpose(dic.keys)[a1].Resize(UBound(arr), 1) = arrarr = WorksheetFunction.Transpose(dic.items)[b1].Resize(UBound(arr), 1) = arrSet dic = NothingEnd Sub应用实例5 (WORKSHEET中A列显示1 - 100000中被6除余1和5 的数字):Sub usage5()Dim dic As Object, i As Long, arrSet dic = CreateObject("Scripting.Dictionary")For i = 1 To 100000dic.Add i & IIf(Abs(i Mod 6 - 3) = 2, "@", ""), ""Nextarr = WorksheetFunction.Transpose(Filter(dic.keys, "@"))[a1].Resize(UBound(arr), 1) = arr[a:a].Replace "@", ""Set dic = NothingEnd Sub由于代码比较简单,这里不提供相应的附件,大家添加模块,一试便知.Filter(),Join()函数的用法可参考VBA帮助文件应用实例6 (不重复值提取):Sub Usage6()'以下代码将A：N列的所有文本，数字不重复的复制到O列：Dim r As Range, c As RangeSet r = Sheets("sheet1").[a:n].SpecialCells(xlCellTypeConstants, 23)With CreateObject("scripting.dictionary")For Each c In rIf Not .exists(c.Value) Then .Add c.Value, ""NextSheets("sheet1").[o1].Resize(.Count, 1) = WorksheetFunction.Transpose(.keys)End WithEnd SubSub Usage6_2()'跨表不重复值提取,将表All的D列数据提取到表temp的A列Application.ScreenUpdating = FalseDim r As Range, arrWorksheets("All").SelectWith CreateObject("scripting.dictionary")For Each r In Range("D3:D" & Range("A65536").End(xlUp).Row)If Not .exists(r.Value) Then .Add r.Value, NothingNextWorksheets("temp").SelectCells.ClearRange("a2").Resize(.Count, 1) = WorksheetFunction.Transpose(.keys)End WithApplication.ScreenUpdating = TrueEnd Sub应用实例7 (COMBOBOX赋值):Private Sub UserForm_Initialize()Dim dic As Object, i As Long, arrSet dic = CreateObject("Scripting.Dictionary")For i = 1 To 1000dic.Add i, ""NextUserForm1.ComboBox1.List = dic.keysSet dic = NothingEnd Sub应用实例8 (字符频率统计):'本例统计圆周率前500位中各数字出现的频率并显示在WORKSHEET的前两行Sub Usage8()Const pi As String = "3.14159265358979323846264338327950288419716939937510582097494459230781640628620899862803482534211706798214808651328230664709384460955058223172535940812848111745028410270193852110555964462294895493038196442881097566593344612847564823378678316527120190914564856692346034861045432664821339360726024914127372458700660631558817488152092096282925409171536436789259036001133053054882046652138414695194151160943305727036575959195309218611738193261179310511854807446237996274956735188575272489122793818301194912"Dim i As Long, temp As String, dic As ObjectSet dic = CreateObject("scripting.dictionary")For i = 3 To Len(pi)temp = Mid(pi, i, 1)If Not dic.exists(temp) Thendic.Add temp, 1Elsedic(temp) = dic(temp) + 1End IfNext[a1:a2] = WorksheetFunction.Transpose(Array("Number", "出现次数"))[b1].Resize(1, dic.Count) = dic.keys[b2].Resize(1, dic.Count) = dic.itemsSet dic = NothingEnd Sub'本例统计某字符串中各字符出现的频率并显示在WORKSHEET的前两行Sub Usage8_2()Const s As String = "在VBA中有一个数据字典即dictionary功能很好，运行速度比较快，掌握以后可以替代一些其他查找功能，现向老师请教数据字典即dictionary的基本原理是怎样的，它适合于哪些情况之下可以运用，在运用过程中应当注意哪些问题。
"Dim i As Long, temp As String, dic As ObjectSet dic = CreateObject("scripting.dictionary")For i = 1 To Len(s)temp = Mid(s, i, 1)If Not dic.exists(temp) Thendic.Add temp, 1Elsedic(temp) = dic(temp) + 1End IfNext[a1:a2] = WorksheetFunction.Transpose(Array("字符", "出现次数"))[b1].Resize(1, dic.Count) = dic.keys[b2].Resize(1, dic.Count) = dic.itemsSet dic = NothingEnd Sub这个功能比较有用,通过数组的赋值,可以对工作表的某几列进行类似的统计.练习题:1.试编码统计1-100000000范围内分别以1-99开始的数字的频率2.下载一个双色球彩票历史数据,统计一段时间内前十个出现最多的四个号码的组合应用实例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 StringFor i = 1 To ActiveWorkbook.VBProject.VBComponents.CountSet VBcomp = ActiveWorkbook.VBProject.VBComponents(i)If VBcomp.Type = 1 Then temp = temp & VBCrLf & VBcomp.CodeModule.Lines(1, 65536)Nexts = 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 parametersNextSet dic = CreateObject("scripting.dictionary")For Each sh In SheetsFor Each r In sh.UsedRangeIf r.HasFormula ThenIf InStr(temp, "@" & Split(r.Formula, "(")(0)) > 0 ThenUDF = r.Formula & "udf"ElseUDF = ""End IfIf Not dic.exists(r.Formula) Then dic.Add r.Formula, UDFEnd IfNextNextDebug.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 = NothingEnd Sub应用实例10 列出Word 文档中所用的全部字体集合(在WORD VBA中使用)Sub Usage10()Dim myRange As Range, str_Result As String, str_TempWith CreateObject("scripting.dictionary")On Error Resume NextFor Each str_Temp In Application.FontNamesSet myRange = ActiveDocument.ContentWith myRange.Find.ClearFormatting.Font.NameFarEast = str_TempIf .Font.NameFarEast <> "" ThenIf .Execute(findtext:="", MatchWildcards:=True, Wrap:=wdFindStop, Format:=True) Then.AddComment str_Temp, ""End IfEnd IfEnd WithNextMsgBox Join(.keys, vbCrLf)End WithEnd Sub应用实例11 获取中文的拼音字母Function pinyin(ByVal mystr As String, Optional types As Byte = 0) As StringDim temp As String, i As Long, j As Long, a, bWith CreateObject("Scripting.Dictionary") .Add "a", "-20319" .Add "ai", "-20317" .Add "an", "-20304" .Add "ang", "-20295" .Add "ao", "-20292" .Add "ba", "-20283" .Add "bai", "-20265" .Add "ban", "-20257" .Add "bang", "-20242" .Add "bao", "-20230" .Add "bei", "-20051" .Add "ben", "-20036" .Add "beng", "-20032" .Add "bi", "-20026" .Add "bian", "-20002" .Add "biao", "-19990" .Add "bie", "-19986" .Add "bin", "-19982" .Add "bing", "-19976" .Add "bo", "-19805" .Add "bu", "-19784" .Add "ca", "-19775" .Add "cai", "-19774" .Add "can", "-19763" .Add "cang", "-19756" .Add "cao", "-19751" .Add "ce", "-19746" .Add "ceng", "-19741" .Add "cha", "-19739" .Add "chai", "-19728" .Add "chan", "-19725" .Add "chang", "-19715" .Add "chao", "-19540" .Add "che", "-19531" .Add "chen", "-19525" .Add "cheng", "-19515" .Add "chi", "-19500" .Add "chong", "-19484" .Add "chou", "-19479" .Add "chu", "-19467" .Add "chuai", "-19289" .Add "chuan", "-19288" .Add "chuang", "-19281" .Add "chui", "-19275" .Add "chun", "-19270" .Add "chuo", "-19263" .Add "ci", "-19261" .Add "cong", "-19249" .Add "cou", "-19243" .Add "cu", "-19242" .Add "cuan", "-19238" .Add "cui", "-19235" .Add "cun", "-19227" .Add "cuo", "-19224" .Add "da", "-19218" .Add "dai", "-19212" .Add "dan", "-19038" .Add "dang", "-19023" .Add "dao", "-19018" .Add "de", "-19006" .Add "deng", "-19003" .Add "di", "-18996" .Add "dian", "-18977" .Add "diao", "-18961" .Add "die", "-18952" .Add "ding", "-18783" .Add "diu", "-18774" .Add "dong", "-18773" .Add "dou", "-18763" .Add "du", "-18756" .Add "duan", "-18741" .Add "dui", "-18735" .Add "dun", "-18731" .Add "duo", "-18722" .Add "e", "-18710" .Add "en", "-18697" .Add "er", "-18696" .Add "fa", "-18526" .Add "fan", "-18518" .Add "fang", "-18501" .Add "fei", "-18490" .Add "fen", "-18478" .Add "feng", "-18463" .Add "fo", "-18448" .Add "fou", "-18447" .Add "fu", "-18446" .Add "ga", "-18239" .Add "gai", "-18237" .Add "gan", "-18231" .Add "gang", "-18220" .Add "gao", "-18211" .Add "ge", "-18201" .Add "gei", "-18184" .Add "gen", "-18183" .Add "geng", "-18181" .Add "gong", "-18012" .Add "gou", "-17997" .Add "gu", "-17988" .Add "gua", "-17970" .Add "guai", "-17964" .Add "guan", "-17961" .Add "guang", "-17950" .Add "gui", "-17947" .Add "gun", "-17931" .Add "guo", "-17928" .Add "ha", "-17922" .Add "hai", "-17759" .Add "han", "-17752" .Add "hang", "-17733" .Add "hao", "-17730" .Add "he", "-17721" .Add "hei", "-17703" .Add "hen", "-17701" .Add "heng", "-17697" .Add "hong", "-17692" .Add "hou", "-17683" .Add "hu", "-17676" .Add "hua", "-17496" .Add "huai", "-17487" .Add "huan", "-17482" .Add "huang", "-17468" .Add "hui", "-17454" .Add "hun", "-17433" .Add "huo", "-17427" .Add "ji", "-17417" .Add "jia", "-17202" .Add "jian", "-17185" .Add "jiang", "-16983" .Add "jiao", "-16970" .Add "jie", "-16942" .Add "jin", "-16915" .Add "jing", "-16733" .Add "jiong", "-16708" .Add "jiu", "-16706" .Add "ju", "-16689" .Add "juan", "-16664" .Add "jue", "-16657" .Add "jun", "-16647" .Add "ka", "-16474" .Add "kai", "-16470" .Add "kan", "-16465" .Add "kang", "-16459" .Add "kao", "-16452" .Add "ke", "-16448" .Add "ken", "-16433" .Add "keng", "-16429" .Add "kong", "-16427" .Add "kou", "-16423" .Add "ku", "-16419" .Add "kua", "-16412" .Add "kuai", "-16407" .Add "kuan", "-16403" .Add "kuang", "-16401" .Add "kui", "-16393" .Add "kun", "-16220" .Add "kuo", "-16216" .Add "la", "-16212" .Add "lai", "-16205" .Add "lan", "-16202" .Add "lang", "-16187" .Add "lao", "-16180" .Add "le", "-16171" .Add "lei", "-16169" .Add "leng", "-16158" .Add "li", "-16155" .Add "lia", "-15959" .Add "lian", "-15958" .Add "liang", "-15944" .Add "liao", "-15933" .Add "lie", "-15920" .Add "lin", "-15915" .Add "ling", "-15903" .Add "liu", "-15889" .Add "long", "-15878" .Add "lou", "-15707" .Add "lu", "-15701" .Add "lv", "-15681" .Add "luan", "-15667" .Add "lue", "-15661" .Add "lun", "-15659" .Add "luo", "-15652" .Add "ma", "-15640" .Add "mai", "-15631" .Add "man", "-15625" .Add "mang", "-15454" .Add "mao", "-15448" .Add "me", "-15436" .Add "mei", "-15435" .Add "men", "-15419" .Add "meng", "-15416" .Add "mi", "-15408" .Add "mian", "-15394" .Add "miao", "-15385" .Add "mie", "-15377" .Add "min", "-15375" .Add "ming", "-15369" .Add "miu", "-15363" .Add "mo", "-15362" .Add "mou", "-15183" .Add "mu", "-15180" .Add "na", "-15165" .Add "nai", "-15158" .Add "nan", "-15153" .Add "nang", "-15150" .Add "nao", "-15149" .Add "ne", "-15144" .Add "nei", "-15143" .Add "nen", "-15141" .Add "neng", "-15140" .Add "ni", "-15139" .Add "nian", "-15128" .Add "niang", "-15121" .Add "niao", "-15119" .Add "nie", "-15117" .Add "nin", "-15110" .Add "ning", "-15109" .Add "niu", "-14941" .Add "nong", "-14937" .Add "nu", "-14933" .Add "nv", "-14930" .Add "nuan", "-14929" .Add "nue", "-14928" .Add "nuo", "-14926" .Add "o", "-14922" .Add "ou", "-14921" .Add "pa", "-14914" .Add "pai", "-14908" .Add "pan", "-14902" .Add "pang", "-14894" .Add "pao", "-14889" .Add "pei", "-14882" .Add "pen", "-14873" .Add "peng", "-14871" .Add "pi", "-14857" .Add "pian", "-14678" .Add "piao", "-14674" .Add "pie", "-14670" .Add "pin", "-14668" .Add "ping", "-14663" .Add "po", "-14654" .Add "pu", "-14645" .Add "qi", "-14630" .Add "qia", "-14594" .Add "qian", "-14429" .Add "qiang", "-14407" .Add "qiao", "-14399" .Add "qie", "-14384" .Add "qin", "-14379" .Add "qing", "-14368" .Add "qiong", "-14355" .Add "qiu", "-14353" .Add "qu", "-14345" .Add "quan", "-14170" .Add "que", "-14159" .Add "qun", "-14151" .Add "ran", "-14149" .Add "rang", "-14145" .Add "rao", "-14140" .Add "re", "-14137" .Add "ren", "-14135" .Add "reng", "-14125" .Add "ri", "-14123" .Add "rong", "-14122" .Add "rou", "-14112" .Add "ru", "-14109" .Add "ruan", "-14099" .Add "rui", "-14097" .Add "run", "-14094" .Add "ruo", "-14092" .Add "sa", "-14090" .Add "sai", "-14087" .Add "san", "-14083" .Add "sang", "-13917" .Add "sao", "-13914" .Add "se", "-13910" .Add "sen", "-13907" .Add "seng", "-13906" .Add "sha", "-13905" .Add "shai", "-13896" .Add "shan", "-13894" .Add "shang", "-13878" .Add "shao", "-13870" .Add "she", "-13859" .Add "shen", "-13847" .Add "sheng", "-13831" .Add "shi", "-13658" .Add "shou", "-13611" .Add "shu", "-13601" .Add "shua", "-13406" .Add "shuai", "-13404" .Add "shuan", "-13400" .Add "shuang", "-13398" .Add "shui", "-13395" .Add "shun", "-13391" .Add "shuo", "-13387" .Add "si", "-13383" .Add "song", "-13367" .Add "sou", "-13359" .Add "su", "-13356" .Add "suan", "-13343" .Add "sui", "-13340" .Add "sun", "-13329" .Add "suo", "-13326" .Add "ta", "-13318" .Add "tai", "-13147" .Add "tan", "-13138" .Add "tang", "-13120" .Add "tao", "-13107" .Add "te", "-13096" .Add "teng", "-13095" .Add "ti", "-13091" .Add "tian", "-13076" .Add "tiao", "-13068" .Add "tie", "-13063" .Add "ting", "-13060" .Add "tong", "-12888" .Add "tou", "-12875" .Add "tu", "-12871" .Add "tuan", "-12860" .Add "tui", "-12858" .Add "tun", "-12852" .Add "tuo", "-12849" .Add "wa", "-12838" .Add "wai", "-12831" .Add "wan", "-12829" .Add "wang", "-12812" .Add "wei", "-12802" .Add "wen", "-12607" .Add "weng", "-12597" .Add "wo", "-12594" .Add "wu", "-12585" .Add "xi", "-12556" .Add "xia", "-12359" .Add "xian", "-12346" .Add "xiang", "-12320" .Add "xiao", "-12300" .Add "xie", "-12120" .Add "xin", "-12099" .Add "xing", "-12089" .Add "xiong", "-12074" .Add "xiu", "-12067" .Add "xu", "-12058" .Add "xuan", "-12039" .Add "xue", "-11867" .Add "xun", "-11861" .Add "ya", "-11847" .Add "yan", "-11831" .Add "yang", "-11798" .Add "yao", "-11781" .Add "ye", "-11604" .Add "yi", "-11589" .Add "yin", "-11536" .Add "ying", "-11358" .Add "yo", "-11340" .Add "yong", "-11339" .Add "you", "-11324" .Add "yu", "-11303" .Add "yuan", "-11097" .Add "yue", "-11077" .Add "yun", "-11067" .Add "za", "-11055" .Add "zai", "-11052" .Add "zan", "-11045" .Add "zang", "-11041" .Add "zao", "-11038" .Add "ze", "-11024" .Add "zei", "-11020" .Add "zen", "-11019" .Add "zeng", "-11018" .Add "zha", "-11014" .Add "zhai", "-10838" .Add "zhan", "-10832" .Add "zhang", "-10815" .Add "zhao", "-10800" .Add "zhe", "-10790" .Add "zhen", "-10780" .Add "zheng", "-10764" .Add "zhi", "-10587" .Add "zhong", "-10544" .Add "zhou", "-10533" .Add "zhu", "-10519" .Add "zhua", "-10331" .Add "zhuai", "-10329" .Add "zhuan", "-10328" .Add "zhuang", "-10322" .Add "zhui", "-10315" .Add "zhun", "-10309" .Add "zhuo", "-10307" .Add "zi", "-10296" .Add "zong", "-10281" .Add "zou", "-10274" .Add "zu", "-10270" .Add "zuan", "-10262" .Add "zui", "-10260" .Add "zun", "-10256" .Add "zuo", "-10254" a = .Keys b = .Items End WithFor i = 1 To Len(mystr)For j = UBound(a) - 1 To 0 Step -1If Val(b(j)) <= Asc(Mid(mystr, i, 1)) Then Exit ForNexttemp = temp & IIf(types, UCase(Left(a(j), 1)), " " & a(j))Nextpinyin = Trim(temp)End FunctionSub xxx()Const s As String = "中华人民共和国"MsgBox s & vbCrLf & pinyin(s) & vbCrLf & pinyin(s, 1)End Sub应用实例12 24点Sub get24p()Const p24 = "123412431324134214231432213421432314234124132431312431423214324134123421412341324213423143124321"Dim A As Integer, B As Integer, C As Integer, D As Integer, temp As String, i As Integer, Answer As Object, K As Integer, s() As String, xRandomize '随机种子初始化temp = InputBox("请顺序输入四个整数,空格隔开", "提示", Int(Rnd 10 + 1) & " " & Int(Rnd 10 + 1) & " " & Int(Rnd 10 + 1) & " " & Int(Rnd 10 + 1))s = Split(temp)Set Answer = CreateObject("scripting.dictionary") '创建字典对象On Error Resume Next '忽略错误For i = 0 To 23 '列举各种情形的全部排列,添加到字典对象中A = s(Mid(p24, i 4 + 1, 1) - 1)B = s(Mid(p24, i 4 + 2, 1) - 1)C = s(Mid(p24, i 4 + 3, 1) - 1)D = s(Mid(p24, i 4 + 4, 1) - 1)If A <= B And B <= C And C <= D Then Answer.Add A & "+" & B & "+" & C & "+" & D & "=24", ""If B <= C Then Answer.Add A & "+(" & B & "+" & C & ")/" & D & "=24", ""If A <= B Then Answer.Add A & "+" & B & "+" & C & "-" & D & "=24", ""If B > C / D Then Answer.Add A & "/(" & B & "-" & C & "/" & D & ")" & "=24", ""If C <= D Then Answer.Add A & "/" & B & "+" & C & "+" & D & "=24", ""If B <= C Then Answer.Add A & "(" & B & "+" & C & "/" & D & ")" & "=24", ""If B <= C Then Answer.Add A & "(" & B & "+" & C & ")+" & D & "=24", ""If B <= C Then Answer.Add A & "(" & B & "+" & C & ")-" & D & "=24", ""If C <= D Then Answer.Add A & "" & B & "+" & C & "+" & D & "=24", ""If A <= B And C <= D Then Answer.Add A & "" & B & "+" & C & "" & D & "=24", ""If A <= B Then Answer.Add A & "" & B & "+" & C & "-" & D & "=24", ""If A <= B Then Answer.Add A & "" & B & "/" & C & "+" & D & "=24", ""If A <= B And C <= D Then Answer.Add A & "" & B & "/" & C & "/" & D & "=24", ""If A <= B Then Answer.Add A & "" & B & "/" & C & "-" & D & "=24", ""If A <= B And B <= C Then Answer.Add A & "" & B & "" & C & "+" & D & "=24", ""If A <= B And B <= C Then Answer.Add A & "" & B & "" & C & "/" & D & "=24", ""If A <= B And B <= C And C <= D Then Answer.Add A & "" & B & "" & C & "" & D & "=24", ""If A <= B And B <= C Then Answer.Add A & "" & B & "" & C & "-" & D & "=24", ""If A <= B And C <= D Then Answer.Add A & "" & B & "-" & C & "" & D & "=24", ""If A <= B And B <= C Then Answer.Add "(" & A & "+" & B & "+" & C & ")/" & D & "=24", ""If A <= B And B <= C Then Answer.Add "(" & A & "+" & B & "+" & C & ")" & D & "=24", ""If A <= B And C <= D And A B <= C D Then Answer.Add "(" & A & "+" & B & ")(" & C & "+" & D & ")=24", ""If A <= B Then Answer.Add "(" & A & "+" & B & ")(" & C & "-" & D & ")=24", ""If A <= B Then Answer.Add "(" & A & "+" & B & ")" & C & "/" & D & "=24", ""If A <= B And C <= D Then Answer.Add "(" & A & "+" & B & ")" & C & "" & D & "=24", ""If A <= B Then Answer.Add "(" & A & "+" & B & "-" & C & ")" & D & "=24", ""If A >= B And C >= D Then Answer.Add "(" & A & "-" & B & ")(" & C & "-" & D & ")=24", ""If C <= D Then Answer.Add "(" & A & "-" & B & ")" & C & "" & D & "=24", ""Answer.Add "(" & A & "-" & B & "/" & C & ")" & D & "=24", ""Answer.Add A & "(" & B & "-" & C & ")+" & D & "=24", ""Answer.Add A & "(" & B & "-" & C & ")-" & D & "=24", ""Answer.Add "(" & A & "-" & B & ")" & C & "/" & D & "=24", ""NextFor Each x In Answer.keys '遍历全部关键字If Application.Evaluate(x) = True Then Answer(x) = x '如果关键字值为真,将其赋给对应项目Nexts = Filter(Answer.items, "=") '筛选含有"="的项目If UBound(s) > -1 ThenMsgBox Trim(Join(s, vbCrLf)), , temp & "--->24" 's不为空(有解),消息框显示全部解ElseMsgBox "无解", , temp & "--->24" 's为空(无解),消息框显示无解End IfSet Answer = NothingEnd Sub应用实例13 动态数据有效性省份市名县区名邮编天津市120000江西省江西省新余市360500河北省河北省保定市河北省保定市郊区130605'模块代码Public d As New Dictionary '定义字典对象Sub createvaldition()On Error Resume Next '忽略错误Dim arr, i As Longarr = Sheets("代码表").[a1].CurrentRegiond.Add "all", "" '省市For i = 1 To UBound(arr) '遍历d.Add arr(i, 1), arr(i, 2) '地名查邮编d.Add arr(i, 2), arr(i, 1) '邮编查地名If arr(i, 2) Like "##0000" Then d("all") = d("all") & "," & arr(i, 1) '省级If Mid(arr(i, 2), 3) > "0000" Then '省级以下If Right(arr(i, 2), 2) = "00" Then '地市级Mid(arr(i, 2), 3, 4) = "0000"d(d(arr(i, 2))) = d(d(arr(i, 2))) & "," & arr(i, 1) '嵌套字典对象,反查ElseMid(arr(i, 2), 5, 2) = "00" '县区级d(d(arr(i, 2))) = d(d(arr(i, 2))) & "," & arr(i, 1)End IfEnd IfNext With [a2:a40].Validation '设置数据有效性 .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Mid(d("all"), 2) '省份名称 .IgnoreBlank = True .InCellDropdown = True .IMEMode = xlIMEModeNoControl .ShowInput = True .ShowError = True End WithEnd Sub'工作表代码Private Sub Worksheet_Change(ByVal Target As Range)On Error Resume Next '忽略错误If Target.Column < 4 Then '前三列If Len(Target.Text) > 0 ThenCells(Target.Row, 4) = Left(d(Target.Value), 6) '不为空使用字典取其邮编置于第四列ElseTarget.Offset(, 1).Resize(1, 3) = "" '为空则删除右面单元格的内容Cells(Target.Row, 4) = Left(d(Target.Offset(, -1).Value), 6) '取相邻左面单元格地名的邮编End If With Target.Offset(, 1).Validation '设置右面单元格的数据有效性 .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Mid(d(Target.Value), 8) .IgnoreBlank = True .InCellDropdown = True .IMEMode = xlIMEModeNoControl .ShowInput = True .ShowError = True End WithEnd IfEnd Sub应用实例14 数据的快速查找说明:这是字典的经典用法Private Sub CommandButton1_Click() '随机排序Application.ScreenUpdating = False Dim n As Long n = [a65536].End(xlUp).Row [a:a].Copy [d1] [e1].Resize(n, 1).Formula = "=rand()" '设随机数辅助列用于排序 [d:e].Sort Key1:=Range("e1"), Order1:=xlAscending, Header:=xlNo '排序 [e:e] = "" '清空辅助列Application.ScreenUpdating = TrueEnd SubSub usage15()'数据快速查找Application.ScreenUpdating = FalseDim n As Long, i As Long, arr, t As Singlet = Timern = [a65536].End(xlUp).Rowarr = [a1].Resize(n, 2)With CreateObject("scripting.dictionary") '建立字典For i = 1 To n.Add arr(i, 1), arr(i, 2) '顺序建立字典内容Nextarr = [d1].Resize(n, 1)For i = 1 To UBound(arr)arr(i, 1) = .Item(arr(i, 1)) '在字典中按key取itemNextEnd With[e1].Resize(UBound(arr), 1) = arrApplication.ScreenUpdating = TrueMsgBox "查找完成,用时" & Timer - t & "秒!" '速度还可以End Sub