字典用法集锦

常见字典用法集锦及代码详解前言字典的简介字典（Dictionary）对象是微软Windows脚本语言中的一个很有用的对象。附带提一下，有名的
正则表达式（RegExp）对象和能方便处理驱动器、文件夹和文件的（FileSystemObject）对象也是微软Windows脚
本语言中的一份子。字典对象相当于一种联合数组，它是由具有唯一性的关键字（Key）和它的项（Item）联合组成。字典对象的方法有6个
：Add方法、Keys方法、Items方法、Exists方法、Remove方法、RemoveAll方法。Add方法向Dictio
nary对象中添加一个关键字项目对。object.Add(key,item)参数object必选项。总是一个Dictio
nary对象的名称。key必选项。与被添加的item相关联的key。item必选项。与被添加的key相关联的
item。说明如果key已经存在，那么将导致一个错误。常用语句：DimdSetd=CreateObject("Scr
ipting.Dictionary")d.Add"a","Athens"d.Add"b","Belgrade"d.Add
"c","Cairo"代码详解1、Dimd：创建变量，也称为声明变量。变量d声明为可变型数据类型(Variant)，d后面
没有写数据类型，默认就是可变型数据类型(Variant)。也有写成DimdAsObject的，声明为对象。2、Setd=
CreateObject("Scripting.Dictionary")：创建字典对象，并把字典对象赋给变量d。这是最常用的一句
代码。所谓的“后期绑定”。用了这句代码就不用先引用c:\windows\system32\scrrun.dll了。3、d.Add
"a","Athens"：添加一关键字”a”和对应于它的项”Athens”。4、d.Add"b",“Belgrade”：添
加一关键字”b”和对应于它的项”Belgrade”。5、d.Add"c",“Cairo”：添加一关键字”c”和对应于它的项”
Cairo”。Exists方法如果Dictionary对象中存在所指定的关键字则返回true，否则返回false。obj
ect.Exists(key)参数object必选项。总是一个Dictionary对象的名称。key必选项。需要在Di
ctionary对象中搜索的key值。常用语句：Dimd,msg$Setd=CreateObject("Scr
ipting.Dictionary")d.Add"a","Athens"d.Add"b","Belgrade"d.
Add"c","Cairo"Ifd.Exists("c")Thenmsg="指定的关键字已经存在。"Elsem
sg="指定的关键字不存在。"EndIf代码详解1、Dimd,msg$：声明变量，d见前例；msg$声明为字符串数
据类型(String)，一般写法为DimmsgAsString。String的类型声明字符为美元号($)。2、Ifd.
Exists("c")Then：如果字典中存在关键字”c”，那么执行下面的语句。3、msg="指定的关键字已经存在。"：把
"指定的关键字已经存在。"字符串赋给变量msg。4、Else：否则执行下面的语句。5、msg="指定的关键字不存在。"：把
"指定的关键字不存在。"字符串赋给变量msg。6、EndIf：结束If…Else…Endif判断。Keys方法返回一个数组，
其中包含了一个Dictionary对象中的全部现有的关键字。object.Keys()其中object总是一个Dict
ionary对象的名称。常用语句：Dimd,kSetd=CreateObject("Scripting.Dicti
onary")d.Add"a","Athens"d.Add"b","Belgrade"d.Add"c","Ca
iro"k=d.Keys[B1].Resize(d.Count,1)=Application.Transpose(k)代码详解
1、Dimd,k：声明变量，d见前例；k默认是可变型数据类型(Variant)。2、k=d.Keys：把字典中存在的所有的关
键字赋给变量k。得到的是一个一维数组，下限为0，上限为d.Count-1。这是数组的默认形式。3、[B1].Resize(d.Co
unt,1)=Application.Transpose(k)：这句代码是很常用很经典的代码，所以这里要多说一些。Resize是
Range对象的一个属性，用于调整指定区域的大小，它有两个参数，第一个是行数，本例是d.Count，指的是字典中关键字的数量，整本
字典中有多少个关键字，本例d.Count=3，因为有3个关键字。呵呵，是不是说多了。第二个是列数，本例是1。这样＝左边的意思就是：
把一个单元格B1调整为以B1开始的一列单元格区域，行数等于字典中关键字的数量d.Count，就是把单元格B1调整为单元格区域B1：
B3了。＝右边的k是个一维数组，是水平排列的，我们知道Excel工作表函数里面有个转置函数Transpose，用它可以把水平排列的
置换成竖向排列。但是在VBA中不能直接使用该工作表函数，需要通过Application对象的WorksheetFunction属性
来使用它。所以完整的写法是Application.WorksheetFunction.Transpose(k)，中间的Works
heetFunction可省略。现在可以解释这句代码了：把字典中所有的关键字赋给以B1单元格开始的单元格区域中。Items方法返回
一个数组，其中包含了一个Dictionary对象中的所有项目。object.Items()其中object总是一个Di
ctionary对象的名称。常用语句：Dimd,tSetd=CreateObject("Scripting.Dic
tionary")d.Add"a","Athens"d.Add"b","Belgrade"d.Add"c","
Cairo"t=d.Items[C1].Resize(d.Count,1)=Application.Transpose(t)代
码详解1、Dimd,t：声明变量，d见前例；t默认是可变型数据类型(Variant)。2、t=d.Items：把字典中所有
的关键字对应的项赋给变量t。得到的也是一个一维数组，下限为0，上限为d.Count-1。这是数组的默认形式。3、[C1].Resi
ze(d.Count,1)=Application.Transpose(t)：有了上面Keys方法的解释这句代码就不用多说了，就
是把字典中所有的关键字对应的项赋给以C1单元格开始的单元格区域中。Remove方法Remove方法从一个Dictionary
对象中清除一个关键字，项目对。object.Remove(key)其中object总是一个Dictionary对象的名称
。key必选项。key与要从Dictionary对象中删除的关键字，项目对相关联。说明如果所指定的关键字，项目对不存在，
那么将导致一个错误。常用语句：DimdSetd=CreateObject("Scripting.Dictionary")
d.Add"a","Athens"d.Add"b","Belgrade"d.Add"c","Cairo"……
d.Remove(“b”)代码详解1、d.Remove(“b”)：清除字典中”b”关键字和与它对应的项。清除之后,现在字典里只有
2个关键字了。RemoveAll方法RemoveAll方法从一个Dictionary对象中清除所有的关键字，项目对。obje
ct.RemoveAll()其中object总是一个Dictionary对象的名称。常用语句：DimdSetd=
CreateObject("Scripting.Dictionary")d.Add"a","Athens"d.Add
"b","Belgrade"d.Add"c","Cairo"……d.RemoveAll代码详解1、d.RemoveAl
l：清除字典中所有的数据。也就是清空这字典，然后可以添加新的关键字和项，形成一本新字典。字典对象的属性有4个：Count属性、Ke
y属性、Item属性、CompareMode属性。Count属性返回一个Dictionary对象中的项目数。只读属性。objec
t.Count其中object一个字典对象的名称。常用语句：Dimd,n%Setd=CreateObject("Sc
ripting.Dictionary")d.Add"a","Athens"d.Add"b","Belgrade"d
.Add"c","Cairo"n=d.Count代码详解1、Dimd,n%：声明变量，d见前例；n被声明为整型数据
类型(Integer)。一般写法为DimnAsInteger。Integer的类型声明字符为百分比号(%)。2、n
=d.Count：把字典中所有的关键字的数量赋给变量n。本例得到的是3。Key属性在Dictionary对象中设置一个k
ey。object.Key(key)=newkey参数：object必选项。总是一个字典(Dictionary)对象的名
称。key必选项。被改变的key值。newkey必选项。替换所指定的key的新值。说明如果在改变一个key时
没有发现该key，那么将创建一个新的key并且其相关联的item被设置为空。常用语句：DimdSetd=Cre
ateObject("Scripting.Dictionary")d.Add"a","Athens"d.Add"b",
"Belgrade"d.Add"c","Cairo"d.Key("c")="d"代码详解1、d.Key("c")
="d"：用新的关键字”d”来替换指定的关键字”c”，这时，字典中就没有关键字c了，只有关键字d了，与d对应的项是”Cairo
”。Item属性在一个Dictionary对象中设置或者返回所指定key的item。对于集合则根据所指定的key返
回一个item。读/写。object.Item(key)[=newitem]参数object必选项。总是一个Diction
ary对象的名称。key必选项。与要被查找或添加的item相关联的key。newitem可选项。仅适用于Dict
ionary对象；newitem就是与所指定的key相关联的新值。说明如果在改变一个key的时候没有找到该item
，那么将利用所指定的newitem创建一个新的key。如果在试图返回一个已有项目的时候没有找到key，那么将创建一个新的
key且其相关的项目被设置为空。常用语句：DimdSetd=CreateObject("Scripting.Dicti
onary")d.Add"a","Athens"d.Add"b","Belgrade"d.Add"c","Ca
iro"MsgBoxd.Item("c")代码详解1、d.Item("c")：获取指定的关键字”c”对应的项。2、Ms
gBox：是一个VBA函数，用消息框显示。如果要详细了解MsgBox函数的，可参见我的另一篇文章“常用VBA函数精选合集”。
http://club.excelhome.net/thread-387253-1-1.htmlCompareMode属性设置或者
返回在Dictionary对象中进行字符串关键字比较时所使用的比较模式。object.CompareMode[=compa
re]参数object必选项。总是一个Dictionary对象的名称。compare可选项。如果提供了此项，compar
e就是一个代表比较模式的值。可以使用的值是0(二进制)、1(文本),2(数据库)。说明如果试图改变一个已经包含有数据
的Dictionary对象的比较模式，那么将导致一个错误。常用语句：DimdSetd=CreateObject("S
cripting.Dictionary")d.CompareMode=vbTextCompared.Add"a","A
thens"d.Add"b","Belgrade"d.Add"c","Cairo"d.Add"B","B
altimore"代码详解1、d.CompareMode=vbTextCompare：设置字典的比较模式是文本，在这种比较
模式下不区分关键字的大小写，即关键字”b”和”B”是一样的。vbTextCompare的值为1，所以上式也可写为d.Compar
eMode=1。如果设置为vbBinaryCompare（值为0），则执行二进制比较，即区分关键字的大小写，此种情况下关键字”
b”和”B”被认为是不一样的。2、d.Add"B","Baltimore"：添加一关键字”B”和对应于它的项”Balt
imore”。由于前面已经设置了比较模式为文本模式，不区分关键字的大小写，即关键字”b”和”B”是一样的，此时发生错误添加失败，因
为字典中已经存在”b”了，字典中的关键字是唯一的，不能添加重复的关键字。实例1普通常见的求不重复值问题一、问题的提出：表格中人
员有很多是重复的，要求编写一段代码，把重复的人员姓名以及重复的次数求出来，复制到另一个表格中。如图实例1－1所示。论坛网址：htt
p://club.excelhome.net/thread-637004-1-1.html图实例1-1二、代码：Subc
fz()Dimi&,Myr&,ArrDimd,k,tSetd=CreateObject("Scripting.D
ictionary")Myr=Sheet1.Cells(Rows.Count,1).End(xlUp).RowArr=
Sheet1.Range("a1:g"&Myr)Fori=2ToUBound(Arr)d(Arr(i,3))=
d(Arr(i,3))+1Nextk=d.keyst=d.itemsSheet2.Activate[a2].Res
ize(d.Count,1)=Application.Transpose(k)[b2].Resize(d.Count,1)
=Application.Transpose(t)[a1].Resize(1,2)=Array("姓名","重复个数"
)Setd=NothingEndSub三、代码详解1、Dimi&,Myr&,Arr：变量i和Myr声明为长整型变量
。也可以写为DimMyrAsLong。Long的类型声明字符为(&)。Arr后面没有写明数据类型，默认就是可变型数据
类型(Variant)。2、Setd=CreateObject("Scripting.Dictionary")：创建字典对象
，并把字典对象赋给变量d。这是最常用的一句代码。所谓的“后期绑定”。用了这句代码就不用先引用c:\windows\system32
\scrrun.dll了。3、Myr=Sheet1.Cells(Rows.Count,1).End(xlUp).Row：
把表1的A列最后一行不为空白的行数赋给变量Myr。这里用了Range对象的End属性，它有4个方向参数，此处的xlUp表示向上，它
的值为3，所以也可写成End(3)。xlDown表示向下，它的值为4；xlToLeft表示向左，它的值为1；xlToRight表示
向右，它的值为2。4、Arr=Sheet1.Range("a1:g"&Myr)：把表1的A1到G列最后一行不为空白的单元
格区域的值赋给变量Arr。这样Arr就是个二维数组了，用数组替代单元格引用可对执行代码的速度提高很多很多。5、Fori=2
ToUBound(Arr)：For…Next循环结构，从2开始到数组的最大上界值之间循环。因为数组的第一行是表头。Ubound
是VBA函数，返回数组的指定维数的最大可用上界。6、d(Arr(i,3))=d(Arr(i,3))+1：Arr(i,
3)在本例是姓名列，也就是关键字列，举个例子，假如Arr(i,3)=”张三”，这句代码的意思就是把关键字”张三”加入字典，d(ke
y)等于关键字key对应的项，每出现一次这个关键字，它的项的值就增加1。起到了按关键字累加的作用，也正因为有这个作用，所以可使用字
典来进行各种汇总统计。后面要讲的实例会充分的展现这个作用。7、k=d.keys：把字典d中存在的所有的关键字赋给变量k。得到的是
一个一维数组，下限为0，上限为d.Count-1。Keys是字典的方法，前面已经讲过了。8、t=d.items：把字典d中存在的
所有的关键字对应的项赋给变量t。得到的也是一个一维数组，下限为0，上限为d.Count-1。Items也是字典的方法，前面也已经讲
过了。9、Sheet2.Activate：激活表2。10、[a2].Resize(d.Count,1)=Applicati
on.Transpose(k)：把字典d中所有的关键字赋给以a2单元格开始的单元格区域中。详细的解释请见前面的keys方法一节。
11、[b2].Resize(d.Count,1)=Application.Transpose(t)：把字典d中所有的关键
字对应的项赋给以b2单元格开始的单元格区域中。12、[a1].Resize(1,2)=Array("姓名","重复个数")
：Array是一个VBA函数，返回一个下界为0的一维数组。一维数组可以看作是水平排列的，所以赋值给水平的单元格区域不需要用转置函
数了。这里作为表头一次性输入。13、Setd=Nothing：释放字典内存。代码执行后如图实例1-2所示。图实例1-2
实例2求多表的不重复值问题一、问题的提出：一工作簿里面有3张工作表上，每张表格的A列都是姓名列，所有这些姓名中有些是重复的
，要求编写一段代码，在另一个工作表上显示不重复的姓名。如图实例2－1所示。图实例2-1这个问题也很适合用字典来解决。代码如
下：二、代码：Subbcfz()Dimi&,Myr&,ArrDimd,k,t,ShtAsWorksheetSe
td=CreateObject("Scripting.Dictionary")ForEachShtInSheets
IfSht.Name<>"Sheet4"ThenMyr=Sht.Cells(Rows.Count,1).End(
xlUp).RowArr=Sht.Range("a2:a"&Myr)Fori=1ToUBound(Arr)
d(Arr(i,1))=""NextEndIfNextk=d.keysSheet4.[a3].Resize(d.C
ount,1)=Application.Transpose(k)Setd=NothingEndSub三、代码详解1、
ForEachShtInSheets：ForEach…Next循环结构，这种形式是VBA特有的，用于对对象的循环非常适
用。意思是在所有的工作表中依次循环。2、IfSht.Name<>"Sheet4"Then：如果这个工作表的名字不等于”S
heet4”时执行下面的代码。3、Myr=Sht.Cells(Rows.Count,1).End(xlUp).Row：求
得这个工作表A列有数据的最后一行的行数，把它赋给变量Myr。这里用了长整型数据类型(Long)，数据范围最大可到2,147,483
,647，是为了避免数据很多的时候会超出整型数据类型(Integer)而出错，因为整型数据类型数据范围最大只到32,767。4、A
rr=Sht.Range("a2:a"&Myr)：把A列数据赋给数组Arr。5、Fori=1ToUBound(
Arr)：For…Next循环结构，从1开始到数组的最大上限值之间循环。Ubound是VBA函数，返回数组的指定维数的最大值。6
、d(Arr(i,1))=“”：这句代码的意思就是把关键字Arr(i,1)加入字典，关键字对应的项为空，相当于字典中的这个
关键字没有解释。和d.AddArr(i,1),""的效果相同，只是代码更简洁一些。7、k=d.keys：把字典d中存在的所有
的关键字赋给变量k。得到的是一个一维数组，下限为0，上限为d.Count-1。Keys是字典的方法，前面已经讲过了。8、Sheet
4.[a3].Resize(d.Count,1)=Application.Transpose(k)：把字典d中所有的关键
字赋给表4以a3单元格开始的单元格区域中。代码执行后如图实例2-2所示。图实例2-2实例3A列中显示1~1000中
被6除余1和余5的数字一、问题的提出：有1、2、3…1000一千个数字，要求编写一段代码，在工作表的A列显示这些数被6除余1和余
5的数字。二、代码：Sub余1余5()‘by:狼版主DimdicAsObject,iAsLong,arrSet
dic=CreateObject("Scripting.Dictionary")Fori=1To1000dic.Ad
di&IIf(Abs(iMod6-3)=2,"@",""),""Nextarr=WorksheetFu
nction.Transpose(Filter(dic.keys,"@"))[a1].Resize(UBound(arr),1
)=arr[a:a].Replace"@",""Setdic=NothingEndSub三、代码详解1、Dimd
icAsObject,iAsLong,arr：也可把字典变量dic声明为对象(Object)，iAsLong是规
范的写法，也可写成i&。2、dic.Addi&IIf(Abs(iMod6-3)=2,"@",""),""
：这句代码的内容比较多，用了两个VBA函数IIf和Abs，用了一个Mod运算符。iMod6就是每一个数除6的余数，题目中有两
个要求：余1和与5，为了从1到1000都同时能满足这两个要求，所以用了Abs(iMod6-3)=2，Abs是取绝对值
函数。另一个VBA函数IIf是根据判断条件返回结果，和If…Then判断结果类似；IIf(Abs(iMod6-3)=2
,"@","")这段的意思是如果符合判断条件，返回”@”否则返回空””。i&IIf(Abs(iMod6-3)
=2,"@","")的意思是把这个数与”@”或者”””连起来作为关键字加入字典dic，关键字相对应的项为空。比如当i=1时，
1是满足上述表达式的，就把”1@”作为关键字加入字典dic；当i=2时，2不满足上述表达式，就把”2”作为关键字加入字典dic
，关键字相对应的项都为空。3、arr=WorksheetFunction.Transpose(Filter(dic.keys,
"@"))：这句代码的内容分为3部分，第1部分是Filter(dic.keys,"@")其中的Filter是一个VBA函数
，VBA函数就是可以直接在代码中使用的，我们平常使用的函数叫工作表函数，如Sum、Sumif、Transpose等等。Filter
函数要求在一维数组中筛选出符合条件的另一个一维数组，式中的dic.keys正是一个一维数组。这里的筛选条件是”@”，也就是把字典关
键字中含有@的关键字筛选出来组成一个新的一维数组，其下标从零开始。第2部分是用工作表函数Transpose转置这个新的一维数组，工
作表函数的使用在前面keys方法一节已经说过了；第2部分是把转置以后的值赋给数组变量Arr。呵呵，狼版主的代码是短了，我的解释却太
长了。4、[a1].Resize(UBound(arr),1)=arr：把数组Arr赋给[a1]单元格开始的区域中。5、[
a:a].Replace"@",""：把A列中的所有的@都替换为空白，只剩下数字了。代码详解的4代码执行后，如图实例3-1所
示。图实例3-1示例代码全部执行后如图实例3-2所示。图实例3-2示例实例4拆分数据不重复一、问题的提出：有一列各种手
机品牌型号的数据，要求编写一段代码，按照品牌划分成没有重复数据的三大类。二、代码：Subcaifen()DimMyr&,Ar
r,x&Dimd,d1,d2,i&,j&Setd=CreateObject("Scripting.Diction
ary")Setd1=CreateObject("Scripting.Dictionary")Setd2=Create
Object("Scripting.Dictionary")Myr=Cells(Rows.Count,1).End(xlUp
).RowArr=Range("a2:a"&Myr)Range("c2:e"&Myr).ClearContentsmy
=Array("MOTO","诺基亚","三星","索爱")gc=Array("OPPO","联想","天语",
"金立","步步高","波导","TCL","酷派")Forx=1ToUBound(Arr)Fori=
0ToUBound(my)IfInStr(Arr(x,1),my(i))>0Thend(Arr(x,1))
=""GoTo100EndIfNextiForj=0ToUBound(gc)IfInStr(Arr(
x,1),gc(j))>0Thend1(Arr(x,1))=""GoTo100EndIfNextj
d2(Arr(x,1))=""100:NextxRange("c2").Resize(UBound(d.keys)+1
,1)=Application.Transpose(d.keys)Range("d2").Resize(UBound(d1.
keys)+1,1)=Application.Transpose(d1.keys)Range("e2").Resize(
UBound(d2.keys)+1,1)=Application.Transpose(d2.keys)EndSub三
、代码详解1、Setd2=CreateObject("Scripting.Dictionary")：针对三个不同的种类，创
建d、d1、d2三个字典对象。2、Myr=Cells(Rows.Count,1).End(xlUp).Row：把A列最后一
行不为空白的行数赋给变量Myr。3、Arr=Range("a2:a"&Myr)：把A2开始的有数据的单元格区域赋给变量A
rr。4、Range("c2:e"&Myr).ClearContents：把C2到E列单元格区域清空。5、my=Arra
y("MOTO","诺基亚","三星","索爱")：VBA函数Array返回一个一维数组，默认下界为0。把Array函数返
回的数组赋给变量my(贸易两汉字的首字母)。6、gc=Array("OPPO","联想","天语","金立","步步高
","波导","TCL","酷派")：把Array函数返回的数组赋给变量gc(国产两汉字的首字母)。7、Forx=1
ToUBound(Arr)：在A列原始数据的数组中逐一循环。8、Fori=0ToUBound(my)：在my数组
中逐一循环。因为有4个贸易机品牌，所以用循环每一个与原始数据比较。9、IfInStr(Arr(x,1),my(i))>0
Then：VBA函数Instr返回在第1个参数中查找的位置，如果返回结果＝0，表示在第1个参数中没有第2个参数存在。本句的意思
是如果找到贸易机品牌的话，执行下面的代码。10、d1(Arr(x,1))=""：接上句，如果上面判断成立，就把Arr(x,
1)加入字典d。11、GoTo100：Goto语句用于无条件地转移到过程中指定的行。这里采用跳出Fori循环，一是为了减少
循环的次数，比如"MOTO"找到的话，后面3个就不需要找了；二是为了跳过两个小循环之后的其它品牌加入第3个字典的d2(Arr(x,
1))=""语句。12、Forj循环与上面相同，为了判断得到国产机类的字典d1。13、d2(Arr(x,1))=""
：如果上述两个小循环都不满足，那么就加入其它品牌类字典里。14、Range("c2").Resize(UBound(d.keys
)+1,1)=Application.Transpose(d.keys)：最后的3句分别把字典的关键字数组转置后赋给相
应的单元格区域。代码执行后如图实例4-1所示。图实例4-1示例山菊花版主用了一个字典对象就解决了上述问题。让我们来学习一下。
四、山菊花版主的代码：Sub拆分()Dimpp1$,pp2$,nRow%,ds,Brr(),s(1To3)A
sIntegerSetds=CreateObject("scripting.dictionary")pp1=Joi
n(WorksheetFunction.Transpose(Range(Range("g2"),Range("g1").End(
xlDown))),",")pp2=Join(WorksheetFunction.Transpose(Range(Rang
e("h2"),Range("h1").End(xlDown))),",")nRow=Range("a1").End(x
lDown).RowArr=Range("a1:a"&nRow)ReDimBrr(1TonRow,1To3
)Fori=2TonRowIfNotds.Exists(Arr(i,1))Thends(Arr(i,1)
)=""Ifpp1Like""&Left(Arr(i,1),2)&""Thens(1)=s(1
)+1Brr(s(1),1)=Arr(i,1)ElseIfpp2Like""&Left(Arr(i,
1),2)&""Thens(2)=s(2)+1Brr(s(2),2)=Arr(i,1)Elses
(3)=s(3)+1Brr(s(3),3)=Arr(i,1)EndIfEndIfNextRange(
"c2:e"&nRow)=BrrEndSub五、代码详解1、pp1=Join(WorksheetFunction.T
ranspose(Range(Range("g2"),_Range("g1").End(xlDown))),",")：这句
代码用了两个VBA函数Join和Transpose，Range("g1").End(xlDown)从G1单元格往下直到最下面的
单元格，遇到空白格就停止。因为本例的G14、G15单元格有另外的数据存在，如果还是用Range("g65536").End(xl
Up)，那么就会把不需要的数据带进去，造成结果出错。Transpose转置函数，前面已经介绍过了。Join函数是通过连接某个数组
中的多个子字符串而创建的一个字符串，本句代码执行后得到pp1="MOTO,诺基亚,三星,索爱"。pp2一句同上句一样，得到另
一个字符串。2、nRow=Range("a1").End(xlDown).Row：把A列最后一行不为空白的行数赋给整型变量
nRow。3、Arr=Range("a1:a"&nRow)：把A列A1开始的有数据的单元格区域赋给变量Arr。4、ReD
imBrr(1TonRow,1To3)：用于为动态数组变量Brr重新分配存储空间。第一维的下界从1到上界nRow，第
二维从1到3。5、Fori=2TonRow：从2到nRow逐一循环。6、IfNotds.Exists(Arr(i
,1))Then：如果字典ds中不存在关键字Arr(i,1)7、ds(Arr(i,1))=""：把Arr(i,
1)作为关键字加入字典ds。8、Ifpp1Like""&Left(Arr(i,1),2)&""Then：
这里山版主用了比较运算符Like来比较pp1和取自Arr(i,1)左边两个字符，再在前后加任意字符组成的字符串，如果满足条件为真
，那么执行下面的语句。9、s(1)=s(1)+1：数组s的第一个元素+1以后赋给数组s的第一个元素。10、Brr(s(1
),1)=Arr(i,1)：把这个关键字赋给第2维为1的另一个数组Brr，也就是我们要求的贸易机类。pp1字符串里都是贸
易机类的品牌。11、ElseIfpp2Like""&Left(Arr(i,1),2)&""Then：同样
，如果满足国产品牌类这个条件，那么执行下面的代码。12、s(2)=s(2)+1：数组s的第二个元素+1以后赋给数组s的第
二个元素。13、Brr(s(2),2)=Arr(i,1)：把这个关键字赋给第2维为2的另一个数组Brr，也就是我们要求的
国产品牌类。pp2字符串里都是国产品牌类的品牌。14、s(3)=s(3)+1：前如果条件都不满足时，数组s的第三个元素+
1以后赋给数组s的第三个元素。15、Brr(s(3),3)=Arr(i,1)：把这个关键字赋给第3维为1的另一个数组Br
r，也就是我们要求的其它品牌类。16、Range("c2:e"&nRow)=Brr：把数组Brr赋给[c2]单元格开始的
区域中。实例5前期绑定的字典实例一、问题的提出：有多列多行数据，其中有重复的行，要求编写一段代码，求得不重复的行数据。如图实例
5-1所示。图实例5-1示例二、代码：Sub保留原数据()‘by:ldy888‘前期绑定，需先引用c:\windows
\system32\scrrun.dllDimdAsNewDictionary,tFori=2To5Set
d(Cells(i,1)&"")=Range(Cells(i,1),Cells(i,4))Nextt=d.ite
ms[A11].Resize(d.Count,4)=Application.Transpose(Application.Tr
anspose(t))EndSub三、代码详解1、DimdAsNewDictionary,t：本段代码需要先引用微
软的脚本运行时库MicrosoftScriptingRuntime，可在VBE窗口，从菜单－工具－引用，然后勾选Microso
ftScriptingRuntime，或者点击浏览，在添加引用对话框中选择c:\windows\system32\scrrun
.dll，并打开，确定。完成引用。在本声明语句中把字典d声明为NewDictionary。这就是”前期绑定”了。上面的实例用的是
创建对象语句：Setd=CreateObject("Scripting.Dictionary")，称为”后期绑定”。不需要先
引用脚本运行时库。2、Setd(Cells(i,1)&"")=Range(Cells(i,1),Cells(i,
4))：把单元格对象加入字典，它对应的项是同一行的单元格区域。注意，这里用了Set，和前面的几例不一样哦。如果用Typename
(d(Cells(i,1)&""))，得到的是一个Range对象。这里的Cells(i,1)&""也可以用Cells(
i,1).Value来代替。3、t=d.items：把字典d中存在的所有的关键字对应的项赋给变量t。得到的是一个一维数组，
下限为0，上限为d.Count-1。4、[A11].Resize(d.Count,4)=Application.Transp
ose(Application.Transpose(t))：这句用了两次工作表转置函数Transpose之后赋给A11单元格开始
的区域中。代码执行后如图实例5-2所示。图实例5-2示例实例6多条件复杂汇总一、问题的提出：有一个表格，需要对其中多个条件
相同的数量进行合并汇总，并且要有汇总的明细数据，要求编写一段代码，实现这样的合并同类项的要求。二、代码：Subkf2()''b
y:oobirdDimdAsObject,a,b,j%,w!Dimss$,n%,xMe.UsedRang
e.Offset(3,0)=""a=Sheet1.Range(Sheet1.[a4],Sheet1.Cells(Ro
ws.Count,"I").End(xlUp).Row)Setd=CreateObject("scripting.dic
tionary")ReDimb(1ToUBound(a),1To8)Fori=1ToUBound(a)
ss=a(i,1)&a(i,2)&a(i,4)&a(i,5)&a(i,6)&a(i,8)If
Notd.Exists(ss)Thenn=n+1d.Addss,nb(n,1)=a(i,2):b
(n,2)=a(i,5):b(n,3)=a(i,6):b(n,4)=a(i,4)b(n,5)=
a(i,1):b(n,6)=a(i,8):b(n,7)=a(i,9)Elseb(d(ss),7)=
b(d(ss),7)&"+"&a(i,9)EndIfNextFori=1Tod.Countx=
Split(b(i,7),"+")Forj=0ToUBound(x)w=w+x(j)Nextjb(
i,8)=b(i,5)b(i,6)w/100:w=0Next[b4].Resize(n,8)
=bEndSub三、代码详解1、DimdAsObject,a,b,j%,w!：Dim语句中的j%等同于Di
mjAsInteger。w!等同于DimwAsSingle。类似的还有ss$等同于DimssAsString
。还有双精度数据类型Double的类型声明字符为#、货币数据类型Currency的类型声明字符为@。2、Me.UsedRange.
Offset(3,0)=""：Offset是Range对象的属性，Offset(3,0)的第一个参数是行数；第二个参数是
列数，意思是往下偏移3行，列不变。Me是活动工作表，相当于Activesheet;UsedRange为已经使用的单元格区域。本句
可解释为：清空第3行以下的单元格。3、a=Sheet1.Range(Sheet1.[a4],Sheet1.Cells(Row
s.Count,“I”).End(xlUp).Row)：把原始数据所在的表1自A4以下的I列最后的非空单元格区域的值赋给变量a
。4、Setd=CreateObject("scripting.dictionary")：创建字典对象d。5、ReDim
b(1ToUBound(a),1To8)：根据数组a的大小重新声明数组b。6、Fori=1ToUBound(
a)：在1和数组a第一维的上界值之间逐一循环。7、ss=a(i,1)&a(i,2)&a(i,4)&a(i
,5)&a(i,6)&a(i,8)：把多个条件比例、位置、项目名称、大系统编号、小系统编号和相同楼层数用连接符号&
连成一个字符串，然后赋给变量ss。8、IfNotd.Exists(ss)Then：If…Then结构利用了字典的Exist
s方法和Not来判断：如果字典d里面不存在ss表示的关键字，那么执行下面的语句。9、n=n+1：把变量n增加1以后仍然赋
给n。10、d.Addss,n：把ss的值作为关键字，n的值作为对应的项一起加入字典d中。n的值实际是关键字的位置次序，如n
=1时是第一个关键字；n=2时是第二个关键字。11、b(n,1)=a(i,2):b(n,2)=a(i,5):b
(n,3)=a(i,6):b(n,4)=a(i,4)：为了使代码看起来简短一些，可以用冒号”:”把多个语句连成
一行。4个语句分别给数组b的各个元素赋以对应的值。12、b(n,5)=a(i,1):b(n,6)=a(i,8):
b(n,7)=a(i,9)：与上述的11条相同。13、否则执行这句：b(d(ss),7)=b(d(ss),7)
&"+"&a(i,9)：d(ss)等于关键字对应的项，在本例里等于对应的n的值。本句是把图纸长度a(i,9)用"+"
连起来赋给数组b，这样就得到了长度明细一栏数据。14、Fori=1Tod.Count：在字典关键字数目中逐一循环。15
、x=Split(b(i,7),"+")：运用VBA函数Split把b(i,7)（长度明细）按照"+"分割，返回一个下
标从零开始的一维数组x。如果要详细了解Split函数的，可参见我的另一篇文章“常用VBA函数精选合集”。http://club.e
xcelhome.net/thread-387253-1-1.html16、Forj=0ToUBound(x)：在上面
的x数组之间逐一循环。17、w=w+x(j)：把变量w加x(j)数组的一个元素以后仍然赋给w。实际得到x数组的累加值。1
8、b(i,8)=b(i,5)b(i,6)w/100:w=0：w求出后经过按要求计算得到的值赋给
数组b的第8列元素。（数量列）另一句把变量w置0。避免在新一次的循环中误加进去。19、[b4].Resize(n,8)=b
：最后把数组b赋给B4开始的单元格区域。代码执行后如图实例6-1所示。图实例6-1示例实例7字典法排序一、问题的提出：A列B
列是按顺序排列的全部股票代码和股票名称，C列D列和E列F列是另外按条件筛选出来的无序的数据，要求编写一段代码，将它们排列到与A列
相同的股票行里面。代码执行前如图实例7-1所示。图实例7-1示例二、代码：PrivateSubCommandButton1_
Click()''by:oobirdDimdAsObject,rng,i%,j%,arrSetd=Cre
ateObject("Scripting.Dictionary")rng=Range("a3:f"&Cells(Rows
.Count,1).End(xlUp).Row)ReDimarr(1ToUBound(rng),1To4)For
i=1ToUBound(rng)d(CStr(rng(i,1)))=iNextiForj=3To
5Step2Fori=1ToCells(Rows.Count,j).End(xlUp).Row-2Ifd
(CStr(rng(i,j)))<>""Thenarr(d(CStr(rng(i,j))),j-2)=rng
(i,j)arr(d(CStr(rng(i,j))),j-1)=rng(i,j+1)EndIfNext
iNextj[c3].Resize(UBound(rng),4)=arrEndSub三、代码详解1、DimdA
sObject,rng,i%,j%,arr：声明各个变量。2、Setd=CreateObject("Script
ing.Dictionary")：创建字典对象d。3、rng=Range("a3:f"&Cells(Rows.Count
,1).End(xlUp).Row)：把A列到F列的单元格区域的值赋给变量rng。4、ReDimarr(1ToUBoun
d(rng),1To4)：根据数组rng的大小重新声明动态数组变量的大小，这里是按最大数量来声明，可避免因声明得小了而导致
代码出错。5、Fori=1ToUBound(rng)：在rng数组中逐一循环。6、d(CStr(rng(i,1)))
=i：把A列的股票代码的值用VBA转换函数CStr转换成字符串以后作为关键字，因为如果不作处理有时候遇到00开始的数据，可能
会失去前面的0。股票代码在数组中的行位置i作为关键字对应的项，一起加入字典d。7、Forj=3To5Step2：前
面的循环得到了整个字典，下面这两个循环用来与字典中的关键字比对而重新排位。Step2是循环的步长，j=3执行以后，j=3+2=5
，从而跳过j=4了。呵呵，这是For…Next循环结构的基础知识，说多了。8、Fori=1ToCells(Rows.Co
unt,j).End(xlUp).Row–2：因为C列和E列的最后一个非空单元格的位置不一样，所以用了Cells(6553
6,j).End(xlUp).Row在循环中分别得到这两列的最后一个非空单元格的行数，由于数组rng是从第3行开始的，为了与下面
引用的rng数组对应，所以需要减去2。全句是在C列和E列中逐一循环。9、Ifd(CStr(rng(i,j)))<>""T
hen：rng(i,j)是C列或者E列的股票代码，本句是如果这个股票代码关键字对应的项不等于空的时候，执行下面的代码。10、a
rr(d(CStr(rng(i,j))),j-2)=rng(i,j)：d(CStr(rng(i,j)))=i见上
述6的解释，表示数组arr的第1维，相当于行；j-2是随着j=3的时候，j-2=1；j=5的时候j-2=3，相当于数组列的参数。把
相应的股票代码赋给相同股票代码的第1列或者是第3列。11、arr(d(CStr(rng(i,j))),j-1)=rng
(i,j+1)：把相应的股票名称赋给相同股票代码的第2列或者是第4列。12、[c3].Resize(UBound(rng)
,4)=arr：把数组arr赋给C3开始的单元格区域。代码执行后如图实例7-2所示。图实例7-2示例实例82级动态数
据有效性问题一、问题的提出：A列是源名称，中间有空格，B列为各个源名称对应的数目不同的代号，C列是目标名称来源于源名称，要求在C列
设置不重复的、没有空格的数据有效性供选择；同时D列目标代号，要求随着C列选择的目标名称的不同，提供对应的代号供选择，是为第2级数据
有效性。代码执行前如图实例8-1所示。图实例8-1示例二、代码：PrivateSubWorksheet_SelectionC
hange(ByValTargetAsRange)IfTarget.Count>1ThenExitSubIfT
arget.Column<>4AndTarget.Column<>3ThenExitSubDimd,i&,
Myr&,Arr,r%,Arr1(),cp$,ks&,js&,j&Setd=CreateObject("Scr
ipting.Dictionary")Myr=[b65536].End(xlUp).RowArr=Range("a2:b"
&Myr)IfTarget.Column=3ThenFori=1ToUBound(Arr)IfArr(i
,1)<>""Thend(Arr(i,1))=""EndIfNextWithTarget.Validat
ion.Delete.AddType:=xlValidateList,AlertStyle:=xlValidAlertSt
op,_Operator:=xlBetween,Formula1:=Join(d.keys,",")EndWithT
arget.Offset(0,1)=""ElseIfTarget.Column=4AndTarget.Offset
(0,-1)<>""ThenFori=1ToUBound(Arr)IfArr(i,1)<>""Th
enr=r+1ReDimPreserveArr1(1Tor)Arr1(r)=iEndIfNext
iFori=1TorIfArr(Arr1(i),1)=Target.Offset(0,-1).TextT
henIfi<>rThenjs=Arr1(i+1)-1Elsejs=Myr-1EndIf
ks=Arr1(i)Forj=ksTojscp=cp&Arr(j,2)&","NextEnd
IfNexticp=Left(cp,Len(cp)-1)WithTarget.Validation.Dele
te.AddType:=xlValidateList,AlertStyle:=xlValidAlertStop,_Ope
rator:=xlBetween,Formula1:=cpEndWithTarget=Split(cp,",")(0
)EndIfSetd=NothingEndSub三、代码详解1、PrivateSubWorksheet_Select
ionChange(ByValTargetAsRange)：本例用的是工作表选择变化事件，只要鼠标点击单元格都会激活这个事
件。Private可译为私有的，限制了这段代码只能在指定的工作表里有效。参数Target声明为单元格区域对象，有了关键字ByVa
l，说明可以按值传递参数。2、IfTarget.Count>1ThenExitSub：由于是鼠标点击单元格都会激活这
个事件,所以最好要作一些限制，使得你能避免点击了不需要激活事件的地方而激活本事件产生错误。本句是如果目标单元格的数目大于1就退出本
过程。这样当你点选了多个单元格的时候，过程运行了这句代码就会结束过程了。3、IfTarget.Column<>4AndT
arget.Column<>3ThenExitSub：再加一个限制，如果目标单元格的列不是3列（C列）也不是4列（D
列）的话就退出过程。4、接着的四句代码分别是声明变量、创建字典对象、B列最后一个非空单元格的行数以及把单元格区域的值赋给数组变量等
等与前面的实例相同。请注意这里选择了B列求最后一个非空单元格的行数，是因为A列各数据之间有空格，如果选择A列，就会遗漏一些数据。5
、IfTarget.Column=3Then：现在分两种情况判断，如果点击的目标单元格是C列的，那么执行下面的代码。6、
IfArr(i,1)<>""Then：在数组Arr之间逐一循环，如果A列数组的值不等于空，就作为关键字加入字典d。这样
就排除了空值进入字典。7、WithTarget.Validation：这里使用了With语句，With语句为我们提供了十分简便
的对象引用手段。使用它有3个优点：可以减少代码的输入量、增加代码的可读性。改善代码的执行效率。在EndWith之前的语句都是对目
标单元格的有效性对象的各个属性进行设置。8、.Delete：先删除该单元格的数据有效性。注意Delete前有个小圆点，在小圆点之
前就省略了Target.Validation，即减少了代码的输入量。这个小圆点不能遗漏，否则会出错。9、.AddType:=xl
ValidateList,AlertStyle:=xlValidAlertStop,_Operator:=xlBetween,
Formula1:=Join(d.keys,",")：Add是有效性对象的方法，向指定区域内添加数据有效性检验。参数Type
是数据有效性类型，当类型等于xlValidateList时，后面的公式1参数Formula1必须包含以逗号分隔的取值列表。参数A
lertStyle是出错警告样式，这里是停止样式；参数Operator是数据有效性运算符，有大于、小于、大于或等于、小于或等于、介
于、不介于、等于、不等于等等，这里取介于；公式1参数Formula1的值用了VBA函数Join，把字典的关键字用逗号分隔后连接起来
赋给公式1参数。这样，目标单元格那的数据有效性中就没有重复值了。10、Target.Offset(0,1)=""：给目标单
元格设置了数据有效性以后，把它同行D列单元格的值清除。这是为了确保D列的值只与C列的目标名称相对应。11、ElseIfTarge
t.Column=4AndTarget.Offset(0,-1)<>""Then：否则如果目标单元格是D列的，并
且同行C列单元格不是空的情况下，执行这下面的代码。Offset属性的详解可见前面实例6的第2条解释。12、Fori=1To
UBound(Arr)：在数组Arr之间逐一循环。13、IfArr(i,1)<>""Then：如果A列数组的值不等
于空，就执行下面的代码。14、r=r+1：变量r累加。15、ReDimPreserveArr1(1Tor)：重
新声明动态数组的大小，Preserve是关键字，当改变原有数组最末维的大小时，使用此关键字可以保持数组中原来的数据。这句是改变动态
数组大小的最常用语句，不能忘记Preserve关键字。16、Arr1(r)=i：把关键字在数组Arr中行的位置赋给新的动态数
组Arr1(r)。这个循环可求得A列每一个源名称所在的行的位置。17、Fori=1Tor：上面的循环求得了一共有r个源
名称，逐一循环。18、IfArr(Arr1(i),1)=Target.Offset(0,-1).TextThen：如
果C列的目标名称等于源名称时执行下面的代码。19、Ifi<>rThen：如果i不等于r时执行下面的代码。20、js=
Arr1(i+1)–1：把下一个源名称所在的行数-1以后赋给变量js，这样来求得每一个源名称的开始和结束的位置。21、j
s=Myr–1：否则就是最后一行－1的只赋给变量js（最后一个源名称在数组中的位置）。22、ks=Arr1(i)：
把数组的值赋给变量ks：得到每一个源名称的起始位置。23、Forj=ksTojs：从每一个源名称的起始位置到结束位置逐
一循环。24、cp=cp&Arr(j,2)&","：把相应的代号与逗号连接起来组成的字符串赋给变量cp。25、cp
=Left(cp,Len(cp)-1)：用了两个VBA函数Left和Len把去掉末位的逗号。26、With语句解释同
上，为D列单元格设置了第2级数据有效性。27、Target=Split(cp,",")(0)：按照问题的第3个要求，在目标
名称确定后，在目标代号相应位置自动生成目标名称的第一个代号。因为Split得到的是一个以0为下界的一维函数，所以它的第一个元素就用
(0)来表示。代码执行后如图实例8-2所示。图实例8-2示例实例9字典取行数，数组重新赋值一、问题的提出：要求编写一段代码，
求得B列不重复的名字，其相应的A列和D列分别用""连起来，而相应的E列F列的数值分别相加汇总。代码执行前如图实例9-1所示。图
实例9-1示例二、代码：Subyy()''by:ZamyiDimdAsNewDictionary,RDimk,i&
,j&R=Sheet1.UsedRangek=1Fori=2ToUBound(R)R(i,2)=Rep
lace(Replace(R(i,2),"（","("),"）",")")Ifd.Exists(R(i,2))T
henR(d(R(i,2)),1)=R(d(R(i,2)),1)&""&R(i,1)R(d(R(i,
2)),4)=R(d(R(i,2)),4)&""&R(i,4)R(d(R(i,2)),5)=Val
(R(d(R(i,2)),5))+R(i,5)R(d(R(i,2)),6)=Val(R(d(R(i,2)),
6))+R(i,6)Elsek=k+1d(R(i,2))=iForj=1ToUBound(
R,2)R(k,j)=R(i,j)NextEndIfNextWithSheet2.Cells.ClearCo
ntents.Cells.Borders.LineStyle=xlNone.[a1:F1].Resize(d.Count
+1)=R.[a1:F1].Resize(d.Count+1).Borders.LineStyle=1EndWi
thSetd=NothingEndSub三、代码详解1、R=Sheet1.UsedRange：把表1的已经使用了的单
元格区域的值赋给变量R。2、k=1：变量k赋初值1。3、Fori=2ToUBound(R)：由于第一行是表头，
所以从第2行开始循环。4、R(i,2)=Replace(Replace(R(i,2),"（","("),"）","
)")：由于源数据中用了不统一的括号，所以加了这句把里面中文括号统一替换为英文括号。这句用了两次VBA函数Replace，一次替
换前半个，另一次替换后半个。Replace函数有6个参数，详细请查阅VBA帮助文件。如果在这里解释，篇幅太长了，也冲淡了字典的主题
。5、Ifd.Exists(R(i,2))Then：这句用字典的Exists方法进行判断，如果字典中存在R(i,2)这个
关键字，那么执行下面的代码。6、这里先解释，Else如果上面的判断不成立，即字典中不存在这个关键字时，要执行下面的代码。7、k=
k+1：变量k+1以后再赋给k。8、d(R(i,2))=i：公司名字作为关键字，对应的项是它所在的行，把它们加入字
典d。9、Forj=1ToUBound(R,2)：知道了这个关键字所在的行，下面这个循环就是重新给数组同一行的各个元
素赋值。UBound(R,2)是用VBA函数Ubound求得数组R的第2维的最大上界。比如本例R数组第1维的最大上界是8，有8行
数据；而第2维的最大上界是6，有6列数据。本循环j就是从第1列到第6列依次循环。10、R(k,j)=R(i,j)：把i行
j列的数组元素赋给k行j列的R数组元素。11、R(d(R(i,2)),1)=R(d(R(i,2)),1)&""
&R(i,1)：再回来说如果R(i,2)这个关键字存在，则执行这条代码。在这之前，这关键字已经加入字典了，它的同一行的各个
数组元素也重新赋过值了，所以根据问题的要求，把A列的数据用""连起来再赋给A列这个数组元素。12、R(d(R(i,2)),4
)=R(d(R(i,2)),4)&""&R(i,4)：D列数据同上。13、R(d(R(i,2)),5)
=Val(R(d(R(i,2)),5))+R(i,5)：E列数据要相加，这里用了VBA函数Val，把E列数组元素转
为数值以后相加汇总。下句类同。14、WithSheet2：With语句，前面介绍过的。15、.Cells.ClearConte
nts：清空表2所有的数据。Cells是工作表对象的属性，指工作表所有的单元格；ClearContents是它的方法，清除里面的
公式、数据，但是保留格式设置。16、.Cells.Borders.LineStyle=xlNone：清除表2所有的边框。Bo
rders是Cells的属性，意思是单元格的边框；LineStyle是边框的属性，为边框的线型，它有直线、虚线、点划线等等，这里取
值xlNone是清除边框。17、.[a1:F1].Resize(d.Count+1)=R：把数组R的值赋给表2A1单元格
开始的区域。18、.[a1:F1].Resize(d.Count+1).Borders.LineStyle=1：给这些单
元格添加边框，线型为直线。代码执行后如图实例9-2所示。图实例9-2示例实例10先字典求得行后显示整行数据一、问题的提出：有
3列数据，要求编写一段代码，如果C列名次、A列主排相同时，根据B列次排最大的只保留一行。解题思路：先对3列数据按主要关键字名次_升
序，次要关键字主排_升序，第3关键字次排_降序进行排序，然后运用字典，以”名次|主排”作为关键字，它所在的行作为关键字的项加入字
典，最后根据行引用相对的单元格值。代码执行前如图实例10-1所示。图实例10-1示例二、代码：Subpmc()Dimi&,
Myr&,ArrDimd,x,rngApplication.ScreenUpdating=FalseSetd=C
reateObject("Scripting.Dictionary")Sheet1.ActivateMyr=Cells(Row
s.Count,1).End(xlUp).RowRange("A1:C"&Myr).SortKey1:=Range("C2"
),Order1:=xlAscending,Key2:=Range(_"A2"),Order2:=xlAscending
,Key3:=Range("B2"),Order3:=xlDescending,_Header:=xlYesArr=R
ange("a2:c"&Myr)Fori=1ToUBound(Arr)x=Arr(i,1)&"|"&
Arr(i,3)IfNotd.exists(x)Thend.Addx,i+1EndIfNext[e:g].
ClearContents[e2].Resize(d.Count,1)=Application.Transpose(d.it
ems)ForEachrngIn[e2].Resize(d.Count,1)rng.Resize(1,3)=Ce
lls(rng,1).Resize(1,3).ValueNextSetd=NothingApplication.Scre
enUpdating=TrueEndSub三、代码详解1、Application.ScreenUpdating=Fals
e：关闭屏幕更新。关闭屏幕更新可加快宏的执行速度。请记住当宏结束执行时，将ScreenUpdating属性设回到True。
2、Range("A1:C"&Myr).SortKey1:=Range("C2"),Order1:=xlAscending
,Key2:=Range("A2"),Order2:=xlAscending,Key3:=Range("B2"),Orde
r3:=xlDescending,_Header:=xlYes：对ABC三列进行排序。主要关键字Key1名次_升序，次要关键字
Key2主排_升序，第3关键字Key3次排_降序。3、Arr=Range("a2:c"&Myr)：把ABC列数据赋给变量
Arr。4、Fori=1ToUBound(Arr)：i从1到数组Arr的最大上界逐一循环。5、x=Arr(i,
1)&"|"&Arr(i,3)：把主排和”|”和名次连起来赋给变量x。6、IfNotd.exists(x)The
n：如果字典中不存在x这个关键字，那么执行下面的代码。7、d.Addx,i+1：把x作为关键字和这个关键字的具体的行作
为对应的项加入字典。因为数组Arr是从A2开始的，所以i与数据的实际行相差1，i+1就是数据的实际行。8、[e:g].ClearC
ontents：清空E~G列。9、[e2].Resize(d.Count,1)=Application.Transpose
(d.items)：把字典所有的项转置以后赋给E2单元格开始的区域。10、ForEachrngIn[e2].Resize
(d.Count,1)：For-Each-Next控制结构是VBA中功能最强的循环控制结构，利用这个结构可对集合中的所有对象
或者数组中的所有元素进行同一操作。它的一个优点在于你不必操心循环应该执行多少次，它循环的次数恰好就是数组中元素的个数（或者集合中对
象的个数），因此对于处理多维数组特别是处理对象时最有效率。本句意思是在E2单元格开始的单元格区域中逐一循环。11、rng.Resi
ze(1,3)=Cells(rng,1).Resize(1,3).Value：把关键字所在行的3个单元格的值赋给rng
开始的3个单元格。在Cells(rng,1)中作为参数的rng＝rng.Valur，而rng.Resize(1,3)处的rng
是一个单元格对象。代码执行后如图实例10-2所示。图实例10-2示例实例11?关键字赋给两列后用Replace方法一、问题的
提出：有如图实例11-1所示的工资表，要求编写一段代码，运用VBA自动生成1季度的工资表。解题思路：先把性别和姓名连起来作为关键字
求得人员的不重复值，然后通过循环查找关键字获得其各月的工资，最后用Replace方法替换两列关键字区域得到各自的数据。代码执行前如
图实例11-1所示。图实例11-1示例二、代码：Subyy()Dimd,k,t,i&,j&,Arr,x,r1S
etd=CreateObject("Scripting.Dictionary")Arr=[a1].CurrentRegi
onFori=1ToUBound(Arr,2)Step3Forj=2ToUBound(Arr)If
Arr(j,i)<>""Thenx=Arr(j,i)&"|"&Arr(j,i+1)d(x)=
""EndIfNextNextk=d.keys[a12:i1000].ClearContents[a13].Resiz
e(d.Count,2)=Application.Transpose(k)[a12:b12]=Array("性别","
姓名")Fori=3ToUBound(Arr,2)Step3Cells(12,2+i/3)=Cel
ls(1,i)NextFori=3ToUBound(Arr,2)Step3Forj=2ToUBoun
d(Arr)IfArr(j,i)<>""Thenx=Arr(j,i-2)&"|"&Arr(j,
i-1)Setr1=[a13].Resize(d.Count,1).Find(x,,,1)Cells(r
1.Row,2+i/3)=Arr(j,i)EndIfNextNext[a13].Resize(d.Count
,1).Replace"|","",xlPart[b13].Resize(d.Count,1).Replace"|
","",xlPartEndSub三、代码详解1、Arr=[a1].CurrentRegion：把含有A1单元格的当前
单元格区域的值赋给变量Arr。CurrentRegion是Range对象的属性，当前区域指以任意空白行及空白列的组合为边界的区域。
如本题A11单元格有数据，但是因为第10行是空白行，所以没有包含在A1的当前区域里面。2、Fori=1ToUBound(
Arr,2)Step3：For-Next控制结构，从1到数组第2维的最大上界每隔3进行一次循环，Step3是循环的步
长，第一次循环时i=1；第2次循环时i=1+3=4，第3次时i=4+3=7。3、Forj=2ToUBound(Arr)
：从第2行开始循环。没有Step时默认Step为1。4、IfArr(j,i)<>""Then：If-Then-Els
e控制结构可根据测试条件的结果改变程序执行的流程。本句测试条件是Arr(j,i)<>""，判断性别是否为空白，如果不为空白则
执行下面的语句，否则，执行Else下面的语句。5、x=Arr(j,i)&"|"&Arr(j,i+1)：把性别
和姓名中间加“|”连起来赋给变量x。6、d(x)=""：把x的值作为关键字加入字典d。比如把”男|赵”加入字典d。这两个循
环把每个月的所有的人员都加入了字典d，字典中的人员是没有重复的。7、k=d.keys：把字典d所有的关键字赋给变量k。8、[
a12:i1000].ClearContents：清空A12：I1000单元格区域。9、[a13].Resize(d.Count
,2)=Application.Transpose(k)：把变量k转置之后赋给A13开始的单元格区域。Resize是Ran
ge对象的属性，调整指定区域的大小，其第1个参数是行的大小，d.Count表示字典关键字的数量，如果有10个关键字，那么就是10行
；其第2个参数是列的大小，一般是赋给1列的，本例关键字由两个数据合并而成，所以先赋给2列，后面再处理。10、[a12:b12]=
Array("性别","姓名")：Array是一个VBA函数，返回一个下界为0的一维数组。一维数组可以看作是水平排列的，这里
作为表头一次性输入。11、Fori=3ToUBound(Arr,2)Step3：从第3列开始循环，步长为3。12
、Cells(12,2+i/3)=Cells(1,i)：把“1月工资“、“2月工资“等输入到相应表头的位置。13
、Setr1=[a13].Resize(d.Count,1).Find(x,,,1)：在A13单元格开始的区域中查
找字符串变量x，Find方法是Range对象的一个方法，其中第4个参数值为1，其常量为xlWhole，表示精确查找，另一个常量为x
lPart，它的值＝2。Find方法返回的是Range对象，所以前面要用Set语句来引用对象。14、Cells(r1.Row,2
+i/3)=Arr(j,i)：把关键字对应的工资赋给相应的单元格里。15、[a13].Resize(d.Count
,1).Replace"|","",xlPart：Replace方法是Range对象的一个方法，其第1个参数是要查找的
字符串，这里"|"是竖线及后面所有的字符串；其第2个参数是替换字符串，这里替换为空；其第3个参数是精确查找还是模糊查找，xlPa
rt常量的值＝2，可以用2代替它。本句是把姓名替换掉，只留下性别；下一句把B列中的性别替换掉，只留下姓名。代码执行后如图实例11-
2所示。图实例11-2示例实例12复杂报表汇总问题的提出：有一日报表，里面有生产型号、生产数量、返修原因、返修数量、报废原
因、报废数量，要求编写一段代码，按同型号产品汇总生产数量；得到同型号产品相同返修原因的唯一值；按同型号产品相同返修原因汇总返修数量
；得到同型号产品相同报废原因的唯一值；同型号产品相同报废原因汇总报废数量，并且合并相同内容的单元格。代码执行前如图实例12-1所
示。图实例12-1示例二、代码：Subbbhz()Dimi&,Myr&,x(1To3),Arr,n%,aa,
j&,Arr1(),r%,Arr2(),r2%,r3%,Arr3()Dimd(1To3)AsNewdict
ionary,k(1To3),t(1To3),js,ks,ii%,jj&,ks1,js1Applicati
on.ScreenUpdating=FalseMyr=Sheet1.Cells(Rows.Count,1).End(xlU
p).RowArr=Sheet1.Range("a3:g"&Myr)Fori=1ToUBound(Arr)x(
1)=Arr(i,2)d(1)(x(1))=d(1)(x(1))+Arr(i,3)x(2)=Arr(i,
2)&"|"&Arr(i,4)d(2)(x(2))=d(2)(x(2))+Arr(i,5)x(3)=A
rr(i,2)&"|"&Arr(i,4)&"|"&Arr(i,6)d(3)(x(3))=d(3)(x(
3))+Arr(i,7)NextFori=1To3k(i)=d(i).Keyst(i)=d(i).It
emsNextSheet4.Activate[a3:k1000].ClearContents[a3:k1000].UnMerge[
a3:k1000].Borders.LineStyle=xlNone[i3].Resize(d(3).Count,1)=
Application.Transpose(t(3))n=2Fori=0ToUBound(k(3))aa=Sp
lit(k(3)(i),"|")n=n+1Cells(n,2)=aa(0)Cells(n,4)=aa(
1)Cells(n,8)=aa(2)NextFori=3TonForj=0ToUBound(k(1)
)IfCells(i,2)=k(1)(j)ThenCells(i,3)=t(1)(j)Cells(i,10
)=Cells(i,9)/Cells(i,3)Cells(i,11)=Cells(i,10):ExitF
orEndIfNextForj=0ToUBound(k(2))IfCells(i,2)&"|"&C
ells(i,4)=k(2)(j)ThenCells(i,5)=t(2)(j)Cells(i,6)=Cel
ls(i,5)/Cells(i,3)Cells(i,7)=Cells(i,6):ExitForEndIf
NextNextRange("a3:k"&n).SortKey1:=Range("b3"),Order1:=xlAsce
nding,Key2:=Range("d3")_,Order2:=xlAscending,Key3:=Range("h3
"),Order3:=xlAscending,Header:=_xlGuessFori=3TonIfCell
s(i,2)<>Cells(i-1,2)Thenr=r+1ReDimPreserveArr1(1T
or)Arr1(r)=iEndIfNextApplication.DisplayAlerts=FalseForj
=1Torr3=0:r2=0Ifj<>rThenjs=Arr1(j+1)-1Else
js=nEndIfks=Arr1(j)Ifjs-ks+1>1ThenCells(ks,1).
Resize(js-ks+1,1).MergeCells(ks,2).Resize(js-ks+1,1).
MergeCells(ks,3).Resize(js-ks+1,1).MergeEndIfCells(ks,
1)=jForii=ksTojsIfii=ksThenr2=r2+1ReDimPreser
veArr2(1Tor2)Arr2(r2)=iiElseIfCells(ii,4)<>Cells(ii-
1,4)Thenr2=r2+1ReDimPreserveArr2(1Tor2)Arr2(r2)=ii
EndIfNextForii=1Tor2Ifii<>r2Thenjs1=Arr2(ii+1)
-1Elsejs1=jsEndIfks1=Arr2(ii)Ifjs1-ks1+1>1The
nCells(ks1,4).Resize(js1-ks1+1,1).MergeForjj=ks1Tojs
1Ifjj<>ks1ThenCells(ks,7)=Cells(ks,7)+Cells(jj,7)En
dIfNextCells(ks1,5).Resize(js1-ks1+1,1).MergeCells(ks1,
6).Resize(js1-ks1+1,1).MergeElseIfii<>1ThenCells(ks,
7)=Cells(ks,7)+Cells(ks1,7)EndIfEndIfNextCells(ks,7
).Resize(js-ks+1,1).MergeForii=ksTojsIfii=ksThen
r3=r3+1ReDimPreserveArr3(1Tor3)Arr3(r3)=iiElseIfCel
ls(ii,8)<>Cells(ii-1,8)Thenr3=r3+1ReDimPreserveArr
3(1Tor3)Arr3(r3)=iiEndIfNextForii=1Tor3Ifii<>r3
Thenjs1=Arr3(ii+1)-1Elsejs1=jsEndIfks1=Arr3(ii)
Ifjs1-ks1+1>1ThenCells(ks1,8).Resize(js1-ks1+1,1).
MergeForjj=ks1Tojs1Ifjj<>ks1ThenCells(ks1,9)=Cell
s(ks1,9)+Cells(jj,9)Cells(ks1,10)=Cells(ks1,10)+Cells
(jj,10)EndIfCells(ks,11)=Cells(ks,11)+Cells(jj,11)Nex
tCells(ks1,9).Resize(js1-ks1+1,1).MergeCells(ks1,10).Res
ize(js1-ks1+1,1).MergeElseIfii<>1ThenCells(ks,11)=
Cells(ks,11)+Cells(ks1,11)EndIfEndIfNextCells(ks,11).R
esize(js-ks+1,1).MergeNextRange("a3:k"&n).Borders.LineStyl
e=1Application.DisplayAlerts=TrueApplication.ScreenUpdating=
TrueEndSub三、代码详解1、Dimd(1To3)AsNewdictionary：本例是前期绑定的，先引用
了脚本运行时库，声明了3个元素的数组为新字典。2、x(1)=Arr(i,2)：把生产型号赋给变量x(1)。3、d(1)(x
(1))=d(1)(x(1))+Arr(i,3)：把相同生产型号和它的生产数量加入字典d(1)，达到汇总的目的。4、
x(2)=Arr(i,2)&"|"&Arr(i,4)：把生产型号和返修原因连起来赋给变量x(2)。5、d(2)
(x(2))=d(2)(x(2))+Arr(i,5)：把相同生产型号和相同返修原因的返修数量加入字典d(2)，达到
汇总的目的。6、x(3)=Arr(i,2)&"|"&Arr(i,4)&"|"&Arr(i,6)：把生
产型号和返修原因和报废原因连起来赋给变量x(3)。7、d(3)(x(3))=d(3)(x(3))+Arr(i,7)：把
相同生产型号和相同返修原因和相同报废原因的报废数量加入字典d(3)，达到汇总的目的。8、Fori=1To3：用一个循环
运用字典的keys方法和items方法把3个字典的关键字和它们的项赋给对应的变量。9、Sheet4.Activate：激活表4。
10、[a3:k1000].ClearContents：清空A3：K1000单元格区域。11、[a3:k1000].UnMerg
e：将该区域所有的合并单元格分解为独立的单元格。12、[a3:k1000].Borders.LineStyle=xlNone
：去除该区域所有的单元格边框。13、[i3].Resize(d(3).Count,1)=Application.Trans
pose(t(3))：把报废数量汇总值的一维数组转置后赋给I3开始的单元格区域。14、n=2：把2赋给变量n。因为循环中要
用到n=n+1，而汇总表的起始行是第3行，所以把n的初值定为2。15、Fori=0ToUBound(k(3))：在字典
d(3)中逐一循环。16、aa=Split(k(3)(i),"|")：VBA函数Split在第6例已经讲过了。把字典d(3
)的关键字分解后赋给变量aa。17、n=n+1：在循环中每循环一次行数就加1。18、Cells(n,2)=aa(0)：把aa数组的第1个元素aa(0)，即生产型号，赋给对应的单元格；下面两句分别把aa数组的第2个元素aa(1)，即返修原因，赋给对应的单元格；把aa数组的第3个元素aa(2)，即报废原因，赋给对应的单元格。19、Fori=3Ton：从第3行开始逐行循环。20、Forj=0ToUBound(k(1))：在一维数组k(1)中循环。21、IfCells(i,2)=k(1)(j)Then：如果生产型号等于字典d(1)的关键字时执行下面的语句。22、Cells(i,3)=t(1)(j)：把这个生产型号的生产数量赋给C列单元格。23、Cells(i,10)=Cells(i,9)/Cells(i,3)：把报废数量除以生产数量得到的报废率赋给J列单元格。24、Cells(i,11)=Cells(i,10):ExitFor：把报废率赋给K列单元格。退出Forj的循环。25、Forj=0ToUBound(k(2))：在一维数组k(2)中循环。26、IfCells(i,2)&"|"&Cells(i,4)=k(2)(j)Then：如果把生产型号和返修原因连起来的值等于字典d(2)的一个关键字时，执行下面的代码。27、Cells(i,5)=t(2)(j)：把相同生产型号和相同返修原因的返修数量赋给E列单元格。28、Cells(i,6)=Cells(i,5)/Cells(i,3)：把返修数量除以生产数量得到的返修率赋给F列单元格。29、Cells(i,7)=Cells(i,6):ExitFor：把返修率赋给G列单元格。退出Forj的循环。30、Range("a3:k"&n).SortKey1:=Range("b3"),Order1:=xlAscending,Key2:=Range("d3"),Order2:=xlAscending,Key3:=Range("h3"),Order3:=xlAscending,Header:=xlGuess：本句开始给表格数据设置格式了。本句是对A3开始的单元格区域按B3_升序、D3_升序、H3_升序排序。31、Fori=3Ton：从第3行开始逐行循环。32、IfCells(i,2)<>Cells(i-1,2)Then：如果B列单元格的值与上一行单元格不相等则执行下面的代码。33、r=r+1：变量r加1以后赋给r。34、ReDimPreserveArr1(1Tor)：重新声明动态数组的大小。Preserve是ReDim语句的关键字，当改变原有数组最末维的大小时，使用此关键字可以保持数组中原来的数据。35、Arr1(r)=i：把单元格所在的行数赋给数组。经过这轮循环就得到了各个生产型号的第一行的行数。也得到了生产型号的总数为r个。36、Application.DisplayAlerts=False：把显示警告设置为关闭，因为下面要合并单元格，Excel会显示一个警告对话框来打断代码的运行，所以先关闭此功能。37、Forj=1Tor：在所有的生产型号中逐一循环。38、r3=0:r2=0：把两个变量设置为零。39、Ifj<>rThen：如果j不等于最后一个生产型号时，执行下面的代码。40、js=Arr1(j+1)–1：把下一个生产型号开始行的上面一行的行数赋给js。41、否则把最后一行的行数n赋给js变量。42、ks=Arr1(j)：把生产型号的开始行的行数赋给变量ks。43、Ifjs-ks+1>1Then：如果结束行减去开始行再加1的值大于1，就说明这个型号有多行需要合并，执行下面的代码。44、Cells(ks,1).Resize(js-ks+1,1).Merge：A列对应的单元格合并；下面B列和C列相应的单元格也合并。45、Cells(ks,1)=j：A列依次填入序号。46、Forii=ksTojs：从开始行到结束行逐一循环。47、Ifii=ksThen：这个循环是为了求得D列返修原因是否有需要合并的单元格，如果ii=ks即是同一个生产型号中第一个返修原因的时候，把行数赋给动态数组，否则如果不等于上一行D列单元格的值时，把行数赋给动态数组的下一个元素。经过这轮循环就得到了这个生产型号每一个返修原因的第一行的行数。也得到了返修原因的总数为r2个。48、Forii=1Tor2：在这个循环中，把D列、E列F列相同的返修原因单元格合并，也汇总了G列的总返修率。49、Cells(ks,7).Resize(js-ks+1,1).Merge：把G列的总返修率单元格区域合并。50、Forii=ksTojs：从开始行到结束行逐一循环。这个循环是为了求得H列报废原因是否有需要合并的单元格，经过这轮循环就得到了这个生产型号每一个报废原因的第一行的行数。也得到了报废原因的总数为r3个。51、Forii=1Tor3：在这个循环中，把H列、I列J列相同的报废原因、报废数量和报废率单元格合并，也汇总了K列的总报废率。52、Range("a3:k"&n).Borders.LineStyle=1：把A3开始的单元格区域设置边框。53、Application.DisplayAlerts=True：开启程序显示警告。54、Application.ScreenUpdating=True：开启屏幕更新。代码执行后如图实例12-2所示。图实例12-2示例后语常见字典用法实例集锦到此告一段落了。字典就象一个二维数组Arr(1ton,1to2)，不过它的第2维的最大上界为2，相当于2列单元格，第1列存放的是关键字，这个关键字是除了数组以外的任何类型；第2列存放的是这个关键字对应的项，它可以是数据的任何类型。我收集的和接触到有关字典的实例的数量有限，一定会有更好更有代表性的实例没有接触到，希望有心人能提供出来，供大家学习分享。谢谢大家！2010-104542