Excel 常见字典用法集锦及代码详解5

你喜欢那个 2012-02-23

展开全文

实例4 拆分数据不重复

一、问题的提出：

有一列各种手机品牌型号的数据，要求编写一段代码，按照品牌划分成没有重复数据的三大类。

二、代码：

Sub caifen()

Dim Myr&, Arr, x&

Dim d, d1, d2, i&, j&

Set d = CreateObject("Scripting.Dictionary")

Set d1 = CreateObject("Scripting.Dictionary")

Set d2 = CreateObject("Scripting.Dictionary")

Myr = [a65536].End(xlUp).Row

Arr = Range("a2:a" & Myr)

Range("c2:e" & Myr).ClearContents

my = Array("MOTO", "诺基亚", "三星", "索爱")

gc = Array("OPPO", "联想", "天语", "金立", "步步高", "波导", "TCL", "酷派")

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:

Next x

Range("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)

End Sub

三、代码详解

1、Set d2 = CreateObject("Scripting.Dictionary") ：针对三个不同的种类，创建d、d1、d2三个字典对象。

2、Myr = [a65536].End(xlUp).Row ：把A列最后一行不为空白的行数赋给变量Myr。

3、Arr = Range("a2:a" & Myr) ：把A2开始的有数据的单元格区域赋给变量Arr。

4、Range("c2:e" & Myr).ClearContents ：把C2到E列单元格区域清空。

5、my = Array("MOTO", "诺基亚", "三星", "索爱") ：VBA函数Array返回一个一维数组，默认下界为0。把Array函数返回的数组赋给变量my(贸易两汉字的首字母)。

6、gc = Array("OPPO", "联想", "天语", "金立", "步步高", "波导", "TCL", "酷派") ：把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循环，一是为了减少循环的次数，比如"MOTO"找到的话，后面3个就不需要找了；二是为了跳过两个小循环之后的其它品牌加入第3个字典的d2(Arr(x, 1)) = ""语句。

12、For j循环与上面相同，为了判断得到国产机类的字典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 拆分()

Dim pp1$, pp2$, nRow%, ds, Brr(), s(1 To 3) As Integer

Set ds = CreateObject("scripting.dictionary")

pp1 = Join(WorksheetFunction.Transpose(Range(Range("g2"), Range("g1").End(xlDown))), ",")

pp2 = Join(WorksheetFunction.Transpose(Range(Range("h2"), Range("h1").End(xlDown))), ",")

nRow = Range("a1").End(xlDown).Row

Arr = Range("a1:a" & 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

Brr(s(1), 1) = Arr(i, 1)

ElseIf pp2 Like "*" & Left(Arr(i, 1), 2) & "*" Then

s(2) = s(2) + 1

Brr(s(2), 2) = Arr(i, 1)

Else

s(3) = s(3) + 1

Brr(s(3), 3) = Arr(i, 1)

End If

Range("c2:e" & nRow) = Brr

End Sub

五、代码详解

1、pp1 = Join(WorksheetFunction.Transpose(Range(Range("g2"), _

Range("g1").End(xlDown))), ",") ：

这句代码用了两个VBA函数Join 和Transpose ，Range("g1").End(xlDown)从G1单元格往下直到最下面的单元格，遇到空白格就停止。因为本例的G14、G15单元格有另外的数据存在，如果还是用Range("g65536").End(xlUp)，那么就会把不需要的数据带进去，造成结果出错。Transpose 转置函数，前面已经介绍过了。Join函数是通过连接某个数组中的多个子字符串而创建的一个字符串，本句代码执行后得到pp1="MOTO, 诺基亚, 三星, 索爱"。