VBA字典与数组知识与实例----字典

*********************************************************************************Excel精英培训数组与字典班第二课课件：字典在VBA中应用****---------兰色幻想原创()**欢迎转截，但禁止用于商业用途*******************************************************************************一、什么是字典？我们为什么要学它？字典(Dictionary)是VBA中提供的一个类似二维数组的可以装数据的对象。为什么要把它起名叫字典？因为它'的使用特征很类似字典。有共有两列,第一列是字,第二列是对字的解释。字典和数组很像，但有一个特征是数组不具备的，就是它可以根据存放的内容定位数据，而数组是根据“标”来定位,如果在数组中查找某个元素是否存在,我们除了调用工作表函数外(注:调用工作表函数会拖慢速度),只能循环的方法来实现.看个例子吧:Subt1()Dimarrarr=Range(a2:b5)Forx=1ToUBound(arr)Ifarr(x,1)=CThenMsgBoxarr(x,2)EndIfNextxEndSub从上面的例子我们就可以看出数组在定位元素时的缺陷,而字典正好可以弥补,利用字典的特征,我们可以完成以下常用功能:1提取唯一值2快速查找3多条件汇总二、字典在哪里？我们如果使用它？字典对象不是EXCEL程序直接附带的,而是在c:\windows\system32\scrrun.dll链接库中,所以我们要想用它,要先调用它.调用字典有两种方法,1引用法:step1:VBE中的工具菜单--引用--浏览---在system32文件夹中找到scrrun.dll后点打开即可.使用dim变量asnewdictionary声明后就可以用了2创建法Setd=CreateObject(Scripting.Dictionary)'使用CreateObject创建对字典对象的引用一向字典内装数据数组可以一次性的从单元格中取数,而字典呢,只能通过循环来装数据,把字装在第一列,把内容装在第二列.1使用add方法装Subq1()DimdicAsNewDictionary'声明的一个字典对象Dimarrarr=Range(a2:b5)'把单元格数据装入内存Forx=1ToUBound(arr)IfNotdic.Exists(arr(x,1))Then'字典的Exists属性可以判断在一个元素字典内的第一列是否存在dic.Addarr(x,1),arr(x,2)'使用add方法向字典内装.字典.add第一列内容,第二列内容EndIfNextxEndSub2使用修改式装Subq2()DimdicAsNewDictionaryDimarrarr=Range(a2:b5)'把单元格数据装入内存Forx=1ToUBound(arr)dic(arr(x,1))=arr(x,2)'如果arr(x,1)在字典中存在,则使用本次item的值替换原来的第二列值,如果不存在,则会创新一个新的keyNextxEndSub二取字典内的详细信息我们装入字典的目的是为了运算和数据处理,所以装入后我们还要从字典中返回相应的数据和信息Subq3()DimdicAsNewDictionaryDimarr,arr1arr=Range(a2:b5)'把单元格数据装入内存Forx=1ToUBound(arr)dic(arr(x,1))=arr(x,2)'如果arr(x,1)在字典中存在,则使用本次item的值替换原来的第二列值,如果不存在,则会创新一个新的keyNextxMsgBoxdic.Count'使用count属性可以返回字典内有多少行MsgBoxdic.Item(B)'或dic(B),可以根据第一列的内容直接返回对应的第二列的值,这个VBA数组只能用循环完成arr1=dic.Keys'把字典内的第一列值一次性的放入arr1中，构成一个一维数组MsgBoxarr1(0)Range(d1).Resize(dic.Count)=Application.Transpose(dic.Items)'通过转换把字典的第二列放入单元格中EndSub三清除字典的元素Subq4()DimdicAsNewDictionaryDimarrarr=Range(a2:b5)'把单元格数据装入内存Forx=1ToUBound(arr)dic(arr(x,1))=arr(x,2)'如果arr(x,1)在字典中存在,则使用本次item的值替换原来的第二列值,如果不存在,则会创新一个新的keyNextxdic.Remove(B)'使用remove可以清除字典内指定的字符,这也是数组做不到的MsgBoxdic.Item(B)dic.RemoveAll'清空字典EndSubSubw1()DimarrDimdAsNewDictionaryd.CompareMode=TextCompare'CompareMode属性的值为TextCompare时,可以忽略大小写,默认大小写是不同的arr=Range(a1:a12)Forx=1ToUBound(arr)IfNotd.Exists(arr(x,1))Thend.Addarr(x,1),EndIfNextxRange(c1).Resize(d.Count)=Application.Transpose(d.Keys)EndSub下面和数组比试一下速度Subw2()'使用字典的耗时是0.04st=TimerDimarrDimdAsNewDictionaryarr=Range(a1:a20000)Forx=1ToUBound(arr)IfNotd.Exists(arr(x,1))Thend.Addarr(x,1),EndIfNextxRange(c1).Resize(d.Count)=Application.Transpose(d.Keys)MsgBoxTimer-tEndSub使用数组Subw3()'使用数组的耗时是10s,是字典的250倍t=TimerDimarr,arr1()arr=Range(a1:a20000)ReDimarr1(1To1)Forx=1ToUBound(arr)Fory=1ToUBound(arr1)Ifarr(x,1)=arr1(y)ThenGoTo100EndIfNextyk=k+1ReDimPreservearr1(1Tok)arr1(k)=arr(x,1)100:00:00NextxRange(d1).Resize(k)=Application.Transpose(arr1)MsgBoxTimer-tEndSub1双向查找Sube1()DimarrDimdAsNewDictionaryarr=Range(a1:b6)Forx=1ToUBound(arr)'把城市放入第一列,简写放入第二列d(arr(x,1))=arr(x,2)NextxForx=1ToUBound(arr)'为了能达到双向查找,把简写放入第一列,把城市放入第二列d(arr(x,2))=arr(x,1)NextxMsgBoxd(上海)MsgBoxd(sh)EndSub2多条件查找Sube2()Dimarr,arr1,arr2(1To2,1To2),arr3DimdAsNewDictionaryarr=Range(a2:d5)arr1=Range(a12:b13)Forx=1ToUBound(arr)d(arr(x,1)&-&arr(x,2))=arr(x,3)&-&arr(x,4)'把字符进行合并放在字典中NextxFory=1ToUBound(arr1)arr3=Split(d(arr1(y,1)&-&arr1(y,2)),-)'拆分字符arr2(y,1)=arr3(0)arr2(y,2)=arr3(1)NextyRange(C12).Resize(2,2)=arr2EndSub单条件求和Subp1()DimdAsNewDictionaryDimarrarr=Range(b2:c5)Forx=1ToUBound(arr)d(arr(x,1))=d(arr(x,1))+arr(x,2)'字典中的相同的key进行累加NextxRange(e2).Resize(d.Count)=Application.Transpose(d.Keys)Range(f2).Resize(d.Count)=Application.Transpose(d.Items)EndSub多条件求和Sube2()Dimarr,arr1,arr2(1To1000,1To2),arr3DimdAsNewDictionaryarr=Range(a2:c6)Forx=1ToUBound(arr)d(arr(x,1)&-&arr(x,2))=d(arr(x,1)&-&arr(x,2))+arr(x,3)'把需要汇总的列进行连接Nextxarr1=d.KeysFory=0ToUBound(arr1)arr3=Split(arr1(y),-)'把连接的产品和型号列进行拆分arr2(y+1,1)=arr3(0)'拆分后的放进arr2数组中arr2(y+1,2)=arr3(1)NextyRange(f2).Resize(d.Count,2)=arr2Range(h2).Resize(d.Count)=Application.Transpose(d.Items)EndSub多列求和Sube3()DimarrDimd1AsNewDictionary,d2AsNewDictionary,d3AsNewDictionaryarr=Range(a2:d6)Forx=1ToUBound(arr)d1(arr(x,1))=d1(arr(x,1))+arr(x,2)'利用d1字典汇总数量d2(arr(x,1))=arr(x,3)'利用d2字典放单价,不汇总d3(arr(x,1))=d3(arr(x,1))+arr(x,4)'利用d3字典汇总金额NextxRange(a13).Resize(d1.Count)=Application.Transpose(d1.Keys)Range(b13).Resize(d1.Count)=Application.Transpose(d1.Items)Range(c13).Resize(d1.Count)=Application.Transpose(d2.Items)Range(d13).Resize(d1.Count)=Application.Transpose(d3.Items)EndSub产品销售量A10B20C15D2AABBBCBDAaBCCDDA959495949594211121112111231423142314543454345434314231423142331233123312633963396339475247524752977597759775568256825682755575557555217421742174819681968196272427242724296629662966236823682368515515515143614361436908908908859885988598641664166416459545954595479947994799989698969896696696696986198619861934993499349985798579857320632063206793679367936441441441590659065906408240824082378437843784120912091209877387738773976197619761121012101210886488648864324432443244860986098609214221