k(i) = d(i).Keys t(i) = d(i).Items Next
Sheet4.Activate [a3:k1000].ClearContents [a3:k1000].UnMerge
[a3:k1000].Borders.LineStyle = xlNone
[i3].Resize(d(3).Count, 1) = Application.Transpose(t(3)) n = 2
For i = 0 To UBound(k(3)) aa = Split(k(3)(i), \ n = n + 1 Cells(n, 2) = aa(0) Cells(n, 4) = aa(1) Cells(n, 8) = aa(2) Next
For i = 3 To n
For j = 0 To UBound(k(1)) If Cells(i, 2) = k(1)(j) Then Cells(i, 3) = t(1)(j)
Cells(i, 10) = Cells(i, 9) / Cells(i, 3) Cells(i, 11) = Cells(i, 10): Exit For End If Next
For j = 0 To UBound(k(2))
If Cells(i, 2) & \& Cells(i, 4) = k(2)(j) Then Cells(i, 5) = t(2)(j)
Cells(i, 6) = Cells(i, 5) / Cells(i, 3) Cells(i, 7) = Cells(i, 6): Exit For End If Next Next
46
Range(\& n).Sort Key1:=Range(\Order1:=xlAscending, Key2:=Range(\_
, Order2:=xlAscending, Key3:=Range(\Order3:=xlAscending, Header:= _ xlGuess For i = 3 To n
If Cells(i, 2) <> Cells(i - 1, 2) Then r = r + 1
ReDim Preserve Arr1(1 To r) Arr1(r) = i End If Next
Application.DisplayAlerts = False For j = 1 To r r3 = 0: r2 = 0 If j <> r Then
js = Arr1(j + 1) - 1 Else js = n End If ks = Arr1(j)
If js - ks + 1 > 1 Then
Cells(ks, 1).Resize(js - ks + 1, 1).Merge Cells(ks, 2).Resize(js - ks + 1, 1).Merge Cells(ks, 3).Resize(js - ks + 1, 1).Merge End If Cells(ks, 1) = j For ii = ks To js If ii = ks Then r2 = r2 + 1
ReDim Preserve Arr2(1 To r2) Arr2(r2) = ii
ElseIf Cells(ii, 4) <> Cells(ii - 1, 4) Then
47
r2 = r2 + 1
ReDim Preserve Arr2(1 To r2) Arr2(r2) = ii End If Next
For ii = 1 To r2 If ii <> r2 Then
js1 = Arr2(ii + 1) - 1 Else js1 = js End If ks1 = Arr2(ii)
If js1 - ks1 + 1 > 1 Then
Cells(ks1, 4).Resize(js1 - ks1 + 1, 1).Merge For jj = ks1 To js1 If jj <> ks1 Then
Cells(ks, 7) = Cells(ks, 7) + Cells(jj, 7) End If Next
Cells(ks1, 5).Resize(js1 - ks1 + 1, 1).Merge Cells(ks1, 6).Resize(js1 - ks1 + 1, 1).Merge Else
If ii <> 1 Then
Cells(ks, 7) = Cells(ks, 7) + Cells(ks1, 7) End If End If Next
Cells(ks, 7).Resize(js - ks + 1, 1).Merge For ii = ks To js If ii = ks Then r3 = r3 + 1
ReDim Preserve Arr3(1 To r3)
48
Arr3(r3) = ii
ElseIf Cells(ii, 8) <> Cells(ii - 1, 8) Then r3 = r3 + 1
ReDim Preserve Arr3(1 To r3) Arr3(r3) = ii End If Next
For ii = 1 To r3 If ii <> r3 Then
js1 = Arr3(ii + 1) - 1 Else js1 = js End If ks1 = Arr3(ii)
If js1 - ks1 + 1 > 1 Then
Cells(ks1, 8).Resize(js1 - ks1 + 1, 1).Merge For jj = ks1 To js1 If jj <> ks1 Then
Cells(ks1, 9) = Cells(ks1, 9) + Cells(jj, 9) Cells(ks1, 10) = Cells(ks1, 10) + Cells(jj, 10) End If
Cells(ks, 11) = Cells(ks, 11) + Cells(jj, 11) Next
Cells(ks1, 9).Resize(js1 - ks1 + 1, 1).Merge Cells(ks1, 10).Resize(js1 - ks1 + 1, 1).Merge Else
If ii <> 1 Then
Cells(ks, 11) = Cells(ks, 11) + Cells(ks1, 11) End If End If Next
Cells(ks, 11).Resize(js - ks + 1, 1).Merge
49
Next
Range(\& n).Borders.LineStyle = 1 Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub
三、代码详解
1、Dim d(1 To 3) As New dictionary ：本例是前期绑定的，先引用了脚本运行时库，声明了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) & \ ：把生产型号和返修原因连起来赋给变量x(2)。 5、d(2)(x(2)) = d(2)(x(2)) + Arr(i, 5) ： 把相同生产型号和相同返修原因的返修数量加入字典d(2)，达到汇总的目的。
6、x(3) = Arr(i, 2) & \ ：把生产型号和返修原因和报废原
因连起来赋给变量x(3)。
7、d(3)(x(3)) = d(3)(x(3)) + Arr(i, 7) ：把相同生产型号和相同返修原因和相同报废原因的报废数量加入字典d(3)，达到汇总的目的。
8、For i = 1 To 3 ：用一个循环运用字典的keys方法和items方法把3个字典的关键字和它们的项赋给对应的变量。 9、Sheet4.Activate ：激活表4。
10、[a3:k1000].ClearContents ：清空A3：K1000单元格区域。
11、[a3:k1000].UnMerge ：将该区域所有的合并单元格分解为独立的单元格。 12、[a3:k1000].Borders.LineStyle = xlNone ：去除该区域所有的单元格边框。
13、[i3].Resize(d(3).Count, 1) = Application.Transpose(t(3)) ：把报废数量汇总值的一维数组转置后赋给I3开始的单元格区域。
14、n = 2 ：把2赋给变量n。因为循环中要用到n=n+1，而汇总表的起始行是第3行，所以把n的初值定为2。
15、For i = 0 To UBound(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、For i = 3 To n ：从第3行开始逐行循环。
20、For j = 0 To UBound(k(1)) ：在一维数组k(1)中循环。
50