发布时间 : 星期一 文章VBA字典用法集锦及代码详解更新完毕开始阅读
实例3 A列中显示1 ~ 1000中被6除余1和余5 的数字
图实例3-1 示例
代码全部执行后如图实例3-2所示。
图实例3-2 示例
17
常见字典用法集锦及代码详解
实例4 拆分数据不重复
一、问题的提出：
有一列各种手机品牌型号的数据，要求编写一段代码，按照品牌划分成没有重复数据的三大类。 二、代码： Sub caifen() Dim Myr&, Arr, x& Dim d, d1, d2, i&, j&
Set d = CreateObject(\Set d1 = CreateObject(\Set d2 = CreateObject(\Myr = [a65536].End(xlUp).Row Arr = Range(\& Myr) Range(\& Myr).ClearContents
my = Array(\\诺基亚\\三星\\索爱\
gc = Array(\\联想\\天语\\金立\\步步高\\波导\\\酷派\For x = 1 To UBound(Arr) For i = 0 To UBound(my)
If InStr(Arr(x, 1), my(i)) > 0 Then d(Arr(x, 1)) = \ GoTo 100 End If Next i
For j = 0 To UBound(gc)
If InStr(Arr(x, 1), gc(j)) > 0 Then d1(Arr(x, 1)) = \ GoTo 100 End If Next j
d2(Arr(x, 1)) = \100:
18
实例4 拆分数据不重复
Next x
Range(\+ 1, 1) = Application.Transpose(d.keys) Range(\+ 1, 1) = Application.Transpose(d1.keys) Range(\+ 1, 1) = Application.Transpose(d2.keys) End Sub
三、代码详解
1、Set d2 = CreateObject(\ ：针对三个不同的种类，创建d、d1、d2三个字典对象。
2、Myr = [a65536].End(xlUp).Row ：把A列最后一行不为空白的行数赋给变量Myr。
3、Arr = Range(\ ：把A2开始的有数据的单元格区域赋给变量Arr。 4、Range(\：把C2到E列单元格区域清空。
5、my = Array(\\诺基亚\\三星\\索爱\ ：VBA函数Array返回一个一维数组，默认下界为0。把Array函数返回的数组赋给变量my(贸易两汉字的首字母)。 6、gc = Array(\联想\天语\金立\步步高\波导\酷派\ ：把Array函数返回的数组赋给变量gc(国产两汉字的首字母)。
7、For x = 1 To UBound(Arr) ：在A列原始数据的数组中逐一循环。
8、For i = 0 To UBound(my) ：在my数组中逐一循环。因为有4个贸易机品牌，所以用循环每一个与原始数据比较。
9、If InStr(Arr(x, 1), my(i)) > 0 Then ：VBA函数Instr返回在第1个参数中查找的位
置，如果返回结果＝0，表示在第1个参数中没有第2个参数存在。本句的意思是如果找到贸易机品牌的话，执行下面的代码。
10、d1(Arr(x, 1)) = \ ：接上句，如果上面判断成立，就把Arr(x, 1)加入字典d。 11、GoTo 100 ：Goto语句用于无条件地转移到过程中指定的行。这里采用跳出For i循环，一是为了减少循环的次数，比如\找到的话，后面3个就不需要找了；二是为了跳过两个小循环之后的其它品牌加入第3个字典的d2(Arr(x, 1)) = \语句。
12、For j循环与上面相同，为了判断得到国产机类的字典d1。
13、d2(Arr(x, 1)) = \ ：如果上述两个小循环都不满足，那么就加入其它品牌类字典里。
14、Range(\+ 1, 1) = Application.Transpose(d.keys) ：最后的3句分别把字典的关键字数组转置后赋给相应的单元格区域。
代码执行后如图实例4-1所示。
19
常见字典用法集锦及代码详解
图 实例4-1 示例
山菊花版主用了一个字典对象就解决了上述问题。让我们来学习一下。
四、山菊花版主的代码： Sub 拆分()
Dim pp1$, pp2$, nRow%, ds, Brr(), s(1 To 3) As Integer Set ds = CreateObject(\
pp1 = Join(WorksheetFunction.Transpose(Range(Range(\Range(\wn))), \
pp2 = Join(WorksheetFunction.Transpose(Range(Range(\Range(\wn))), \
nRow = Range(\ Arr = Range(\& nRow) ReDim Brr(1 To nRow, 1 To 3) For i = 2 To nRow
If Not ds.Exists(Arr(i, 1)) Then ds(Arr(i, 1)) = \
If pp1 Like \& Left(Arr(i, 1), 2) & \Then s(1) = s(1) + 1
20