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

abxboy

非常感谢老师辛勤的付出

excel002009

蓝桥玄霜 发表于 2010-10-18 12:56
实例11  关键字赋给两列后用Replace方法
一、问题的提出：
有如图实例11-1所示的工资表，要求编写一段代 ...

实例12：解法有点小问题返修和报废不是二三级排序，而是型号内同级排序，互不干扰。
还可以考虑返修和报废种类数不对等的情况。

1. Sub lastDemo()
   
2.     Dim d(1 To 3), arr(), originArr, fNum%, bNum%, xhNum%, targetArr(), xh, fxArr, bfArr, minRow%, maxRow%, dataRows&, tempVal, y%
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     ReDim arr(1 To 7, 1 To 100)
   
6.     ReDim targetArr(1 To 11, 1 To 100)
   
7.     For i = 1 To 3
   
8.         Set d(i) = CreateObject("Scripting.Dictionary")
   
9.     Next
   
10.     originArr = Worksheets("日报表").Range("a3:g" & Worksheets("日报表").Range("g" & Worksheets("日报表").Rows.Count).End(xlUp).Row)
    
11.     For i = 1 To UBound(originArr)
    
12.         If Not d(1).Exists(originArr(i, 2)) Then
    
13.             xhNum = xhNum + 1   '累计不重复型号(也是每个型号对应行)
    
14.             d(1)(originArr(i, 2)) = xhNum
    
15.             If xhNum > UBound(arr, 2) Then ReDim Preserve arr(1 To 7, 1 To UBound(arr, 2) + 100) '减少数组扩容次数
    
16.             arr(1, xhNum) = originArr(i, 2)
    
17.         End If
    
18.         arr(2, d(1)(originArr(i, 2))) = arr(2, d(1)(originArr(i, 2))) + originArr(i, 3)   '型号内生产数量累计
    
19.         arr(3, d(1)(originArr(i, 2))) = arr(3, d(1)(originArr(i, 2))) + originArr(i, 5)   '型号内返修数量累计
    
20.         arr(4, d(1)(originArr(i, 2))) = arr(4, d(1)(originArr(i, 2))) + originArr(i, 7)   '型号内报废数量累计
    
21.         '型号内指定返修原因返修数量汇总
    
22.         d(2)(originArr(i, 2) & "|" & originArr(i, 4)) = d(2)(originArr(i, 2) & "|" & originArr(i, 4)) + originArr(i, 5)
    
23.         '型号内指定报废原因报废数量汇总
    
24.         d(3)(originArr(i, 2) & "|" & originArr(i, 6)) = d(3)(originArr(i, 2) & "|" & originArr(i, 6)) + originArr(i, 7)
    
25.     Next
    
26.     ReDim Preserve arr(1 To 7, 1 To xhNum)
    
27.     dataRows = 0
    
28.     For Each xh In d(1).Keys
    
29.         '每个型号
    
30.         '其下所有返修原因
    
31.         fxArr = Filter(d(2).Keys, xh & "|")
    
32.         '其下所有报废原因
    
33.         bfArr = Filter(d(3).Keys, xh & "|")
    
34.         '需考虑可能出现某个型号对应的返修、报废种类数不对等
    
35.         If UBound(fxArr) < UBound(bfArr) Then
    
36.             minRow = UBound(fxArr): maxRow = UBound(bfArr)
    
37.             arr(6, d(1)(xh)) = dataRows + minRow + 1 & "|" & (maxRow - minRow + 1)  '返修可能需合并行起始|行数
    
38.         ElseIf UBound(fxArr) > UBound(bfArr) Then
    
39.             maxRow = UBound(fxArr): minRow = UBound(bfArr)
    
40.             arr(7, d(1)(xh)) = dataRows + minRow + 1 & "|" & (maxRow - minRow + 1)   '报废可能需合并行起始|行数
    
41.         Else
    
42.             minRow = UBound(fxArr): maxRow = UBound(fxArr)
    
43.         End If
    
44.         arr(5, d(1)(xh)) = dataRows + 1 & "|" & (maxRow + 1)  '序号、型号、总返修、报废率需合并行起始|行数
    
45.         For i = 0 To minRow
    
46.             dataRows = dataRows + 1
    
47.             If dataRows > UBound(targetArr, 2) Then ReDim Preserve targetArr(1 To 11, 1 To UBound(targetArr, 2) + 100)
    
48.             targetArr(1, dataRows) = d(1)(xh)         '序号
    
49.             targetArr(2, dataRows) = xh               '型号
    
50.             targetArr(3, dataRows) = arr(2, d(1)(xh)) '生产数量
    
51.             targetArr(4, dataRows) = fxArr(i)         '返修原因
    
52.             targetArr(5, dataRows) = d(2)(fxArr(i)) '返修数量
    
53.             targetArr(6, dataRows) = Val(d(2)(fxArr(i))) / Val(arr(2, d(1)(xh))) '返修率
    
54.             targetArr(7, dataRows) = Val(arr(3, d(1)(xh))) / Val(arr(2, d(1)(xh)))  '总返修率
    
55.             targetArr(8, dataRows) = bfArr(i)    '报废原因
    
56.             targetArr(9, dataRows) = d(3)(bfArr(i))   '报废数量
    
57.             targetArr(10, dataRows) = Val(d(3)(bfArr(i))) / Val(arr(2, d(1)(xh)))  '报废率
    
58.             targetArr(11, dataRows) = Val(arr(4, d(1)(xh))) / Val(arr(2, d(1)(xh)))   '总报废率
    
59.         Next
    
60.         For i = minRow + 1 To maxRow
    
61.             dataRows = dataRows + 1
    
62.             If dataRows > UBound(targetArr, 2) Then ReDim Preserve targetArr(1 To 11, 1 To UBound(targetArr, 2) + 100)
    
63.             If arr(6, d(1)(xh)) <> "" Then '报废多
    
64.                 targetArr(8, dataRows) = bfArr(i)    '报废原因
    
65.                 targetArr(9, dataRows) = d(3)(bfArr(i))   '报废数量
    
66.                 targetArr(10, dataRows) = Val(d(3)(bfArr(i))) / Val(arr(2, d(1)(xh)))  '报废率
    
67.                 targetArr(11, dataRows) = Val(arr(4, d(1)(xh))) / Val(arr(2, d(1)(xh)))   '总报废率
    
68.             ElseIf arr(7, d(1)(xh)) <> "" Then  '返修多
    
69.                 targetArr(4, dataRows) = fxArr(i)         '返修原因
    
70.                 targetArr(5, dataRows) = d(2)(fxArr(i)) '返修数量
    
71.                 targetArr(6, dataRows) = Val(d(2)(fxArr(i))) / Val(arr(2, d(1)(xh))) '返修率
    
72.                 targetArr(7, dataRows) = Val(arr(3, d(1)(xh))) / Val(arr(2, d(1)(xh)))  '总返修率
    
73.             End If
    
74.             targetArr(1, dataRows) = d(1)(xh)         '序号
    
75.             targetArr(2, dataRows) = xh               '型号
    
76.             targetArr(3, dataRows) = arr(2, d(1)(xh)) '生产数量
    
77.         Next
    
78.     Next
    
79.     ReDim Preserve targetArr(1 To 11, 1 To dataRows)
    
80.     '排序
    
81.     '直接取dataRows,或重新Preserve
    
82.     For i = UBound(targetArr, 2) To 2 Step -1  'UBound(targetArr, 2) 数组容量赋得大,导致后面列空值最小,排到前面去了
    
83.         For j = 1 To i - 1
    
84.             If targetArr(2, j) > targetArr(2, j + 1) Then
    
85.                 For y = 1 To 11
    
86.                     tempVal = targetArr(y, j): targetArr(y, j) = targetArr(y, j + 1): targetArr(y, j + 1) = tempVal
    
87.                 Next
    
88.             ElseIf targetArr(2, j) = targetArr(2, j + 1) Then
    
89.                 '同一型号内返修、报废原因各自需要排序
    
90.                 If targetArr(4, j) > targetArr(4, j + 1) And targetArr(4, j + 1) <> "" Then
    
91.                     For y = 4 To 6
    
92.                         tempVal = targetArr(y, j): targetArr(y, j) = targetArr(y, j + 1): targetArr(y, j + 1) = tempVal
    
93.                     Next
    
94.                 End If
    
95.                 If targetArr(8, j) > targetArr(8, j + 1) And targetArr(8, j + 1) <> "" Then
    
96.                     For y = 8 To 10
    
97.                         tempVal = targetArr(y, j): targetArr(y, j) = targetArr(y, j + 1): targetArr(y, j + 1) = tempVal
    
98.                     Next
    
99.                 End If
    
100.             End If
     
101.         Next
     
102.     Next
     
103.     With Worksheets("Sheet2")
     
104.         .Range("a3:k" & Rows.Count).Clear
     
105.         .Range("f3:g" & Rows.Count).NumberFormatLocal = "0.00%"
     
106.         .Range("j3:k" & Rows.Count).NumberFormatLocal = "0.00%"
     
107.         .Range("a3").Resize(dataRows, 11) = Application.Transpose(targetArr)
     
108.         .Range("D:D").Replace What:="*|", Replacement:="", LookAt:=xlPart
     
109.         .Range("H:H").Replace What:="*|", Replacement:="", LookAt:=xlPart
     
110.     End With
     
111.     For i = 1 To UBound(arr, 2)
     
112.         tempVal = arr(5, i)
     
113.         '1 2 3 7 11
     
114.         For x = 1 To 3
     
115.             Worksheets("Sheet2").Cells(Val(Split(tempVal, "|")(0)) + 2, x).Resize(Val(Split(tempVal, "|")(1)), 1).Merge
     
116.         Next
     
117.         Worksheets("Sheet2").Cells(Val(Split(tempVal, "|")(0)) + 2, 7).Resize(Val(Split(tempVal, "|")(1)), 1).Merge
     
118.         Worksheets("Sheet2").Cells(Val(Split(tempVal, "|")(0)) + 2, 11).Resize(Val(Split(tempVal, "|")(1)), 1).Merge
     
119.         For x = 1 To 2
     
120.             tempVal = arr(x + 5, i)
     
121.             If tempVal <> "" Then
     
122.                 Worksheets("Sheet2").Cells(Val(Split(tempVal, "|")(0)) + 2, x * 4).Resize(Val(Split(tempVal, "|")(1)), 1).Merge
     
123.                 Worksheets("Sheet2").Cells(Val(Split(tempVal, "|")(0)) + 2, x * 4 + 1).Resize(Val(Split(tempVal, "|")(1)), 1).Merge
     
124.                 Worksheets("Sheet2").Cells(Val(Split(tempVal, "|")(0)) + 2, x * 4 + 2).Resize(Val(Split(tempVal, "|")(1)), 1).Merge
     
125.                 Exit For
     
126.             End If
     
127.         Next
     
128.     Next
     
129.     With Worksheets("Sheet2").Range("a3").Resize(dataRows, 11).Borders
     
130.         .LineStyle = xlContinuous
     
131.         .Weight = xlThin
     
132.     End With
     
133.     Application.ScreenUpdating = True
     
134.     Application.DisplayAlerts = True
     
135. End Sub
     
136. 
     
137. 
     
138. 
     

复制代码

thomas770404

学习了，非常感谢

pjoil

太有用了，感谢各位大佬的详细说明。

前进者

总结的真好，VBA小白学习一下！

weiliang2018

拜读下，一直搞不明白字典的用途、用法，感谢老师的无私奉献

lychenxd

讲的真清楚，谢谢蓝桥玄霜分享！

艾亚Arya

收藏收藏收藏

yanglinzi

讲解的非常详细。谢谢

gwjkkkkk

谢谢楼主,整理不易