【VBA字典数组201301班】课前热身习题二

sliang28

18点35分前下载附件前的同学请重新下载,由于我的失误,附件结果表有误{:212:}


此题目为查找汇总数据!方法不限,拼的就是时间{:3912:}

本次不给目标时间,结果是我用函数做的,不知道要多少时间.

当然你们不许用函数.{:2312:}


快来下载吧,比起习题一应该简单了好多.

备注:上交是只贴出代码即可,代码中不要改工作表的名称.

fffox

不要贴代码吗？
那就删代码传附件，请老师评点！

CheryBTL

终于有结果了，中间的转换搞了1个多小时，0.22S：

1. Sub CheryBTL()
   
2.     Dim i As Integer, j As Integer, m As Integer, t As Single
   
3.     Dim Mre As Integer, R1 As Integer, L1 As Integer
   
4.     Dim ar1, ar2, ar3, re(1 To 500, 1 To 3) As Single, temp(1 To 500)
   
5.     Dim d As Object, d2 As Object
   
6.     t = Timer
   
7.     Set d = CreateObject("Scripting.Dictionary")
   
8.     Set d2 = CreateObject("Scripting.Dictionary")
   
9.     ar1 = Sheets(1).Range("A1").CurrentRegion
   
10.     ar2 = Sheets(2).Range("A1").CurrentRegion
    
11.     ar3 = Sheets(3).Range("A1").CurrentRegion
    
12.     For i = 2 To UBound(ar3)
    
13.         If Not d.exists(ar3(i, 1)) Then
    
14.             m = m + 1
    
15.             d(ar3(i, 1)) = m
    
16.             For j = 2 To UBound(ar2)
    
17.                 If ar3(i, 1) = ar2(j, 1) Then  '求出Part.No对应的行标
    
18.                     temp(m) = j
    
19.                     Exit For
    
20.                 End If
    
21.             Next j
    
22.         End If
    
23.         If Not d2.exists(ar3(i, 2)) Then
    
24.             For j = 2 To UBound(ar1) 'FAILURE CODE对应的列
    
25.                 If ar1(j, 1) = ar3(i, 2) Then
    
26.                     If ar1(j, 2) = "调整" Then
    
27.                         d2(ar3(i, 2)) = 2
    
28.                     ElseIf ar1(j, 2) = "检查" Then
    
29.                         d2(ar3(i, 2)) = 3
    
30.                     Else
    
31.                         d2(ar3(i, 2)) = 4
    
32.                     End If
    
33.                     Exit For
    
34.                 End If
    
35.             Next j
    
36.         End If
    
37.         Mre = d(ar3(i, 1)) '结果的列标
    
38.         L1 = temp(Mre)  '结果的行标
    
39.         R1 = d2(ar3(i, 2)) 'Failure Code对应的列标
    
40.         re(Mre, R1 - 1) = re(Mre, R1 - 1) + ar2(L1, R1)
    
41.     Next i
    
42.     Sheets("结果").[a2].Resize(d.Count) = Application.Transpose(d.keys)
    
43.     Sheets("结果").[b2].Resize(500, 3) = re
    
44.     MsgBox Timer - t
    
45. End Sub
    

复制代码

CheryBTL

法2将第二个字典提前找好位置，对随机数据应该会减小总的循环次数，数据多时就不一定管用了：

1. Sub CheryBTL_2() '0.139s
   
2.     Dim i As Integer, j As Integer, m As Integer, t As Single
   
3.     Dim Mre As Integer, R1 As Integer, L1 As Integer
   
4.     Dim ar1, ar2, ar3, re(1 To 500, 1 To 3) As Single, temp(1 To 500)
   
5.     Dim d As Object, d2 As Object
   
6.     t = Timer
   
7.     Set d = CreateObject("Scripting.Dictionary")
   
8.     Set d2 = CreateObject("Scripting.Dictionary")
   
9.     ar1 = Sheets(1).Range("A1").CurrentRegion
   
10.     ar2 = Sheets(2).Range("A1").CurrentRegion
    
11.     ar3 = Sheets(3).Range("A1").CurrentRegion
    
12.     For i = 2 To UBound(ar1)
    
13.         If Not d2.exists(ar1(i, 1)) Then
    
14.             If ar1(i, 2) = "调整" Then
    
15.                 d2(ar1(i, 1)) = 2
    
16.             ElseIf ar1(i, 2) = "检查" Then
    
17.                 d2(ar1(i, 1)) = 3
    
18.             Else
    
19.                 d2(ar1(i, 1)) = 4
    
20.             End If
    
21.         End If
    
22.     Next i
    
23.     For i = 2 To UBound(ar3)
    
24.         If Not d.exists(ar3(i, 1)) Then
    
25.             m = m + 1
    
26.             d(ar3(i, 1)) = m
    
27.             For j = 2 To UBound(ar2)
    
28.                 If ar3(i, 1) = ar2(j, 1) Then  '求出Part.No对应的行标
    
29.                     temp(m) = j
    
30.                     Exit For
    
31.                 End If
    
32.             Next j
    
33.         End If
    
34.         Mre = d(ar3(i, 1)) '结果的列标
    
35.         L1 = temp(Mre)  '结果的行标
    
36.         R1 = d2(ar3(i, 2)) 'Failure Code对应的列标
    
37.         re(Mre, R1 - 1) = re(Mre, R1 - 1) + ar2(L1, R1)
    
38.     Next i
    
39.     Sheets("结果").[a2].Resize(d.Count) =Application.Transpose(d.keys)
    
40.     Sheets("结果").[b2].Resize(500, 3) = re
    
41.     MsgBox Timer - t
    
42. End Sub

复制代码

增加屏幕更新和赋值前清空数据，跑到了：0.125s：

1. Sub CheryBTL_3() '0.125s
   
2.     Dim i As Integer, j As Integer, m As Integer, t As Single
   
3.     Dim Mre As Integer, R1 As Integer, L1 As Integer
   
4.     Dim ar1, ar2, ar3, re(1 To 500, 1 To 3) As Single, temp(1 To 500)
   
5.     Dim d As Object, d2 As Object
   
6.     t = Timer
   
7.     Application.ScreenUpdating = False
   
8.     Set d = CreateObject("Scripting.Dictionary")
   
9.     Set d2 = CreateObject("Scripting.Dictionary")
   
10.     ar1 = Sheets(1).Range("A1").CurrentRegion
    
11.     ar2 = Sheets(2).Range("A1").CurrentRegion
    
12.     ar3 = Sheets(3).Range("A1").CurrentRegion
    
13.     For i = 2 To UBound(ar1)
    
14.         If Not d2.exists(ar1(i, 1)) Then
    
15.             If ar1(i, 2) = "调整" Then
    
16.                 d2(ar1(i, 1)) = 2
    
17.             ElseIf ar1(i, 2) = "检查" Then
    
18.                 d2(ar1(i, 1)) = 3
    
19.             Else
    
20.                 d2(ar1(i, 1)) = 4
    
21.             End If
    
22.         End If
    
23.     Next i
    
24.     For i = 2 To UBound(ar3)
    
25.         If Not d.exists(ar3(i, 1)) Then
    
26.             m = m + 1
    
27.             d(ar3(i, 1)) = m
    
28.             For j = 2 To UBound(ar2)
    
29.                 If ar3(i, 1) = ar2(j, 1) Then  '求出Part.No对应的行标
    
30.                     temp(m) = j
    
31.                     Exit For
    
32.                 End If
    
33.             Next j
    
34.         End If
    
35.         Mre = d(ar3(i, 1)) '结果的列标
    
36.         L1 = temp(Mre)  '结果的行标
    
37.         R1 = d2(ar3(i, 2)) 'Failure Code对应的列标
    
38.         re(Mre, R1 - 1) = re(Mre, R1 - 1) + ar2(L1, R1)
    
39.     Next i
    
40.     Sheets("结果").[a2].Resize(500, 4).ClearContents
    
41.     Sheets("结果").[a2].Resize(d.Count) = Application.Transpose(d.keys)
    
42.     Sheets("结果").[b2].Resize(500, 3) = re
    
43.     Application.ScreenUpdating = ture
    
44.     MsgBox Timer - t
    
45. End Sub

复制代码

使用三个字典，就快多了（主要原因还是因为源数据多，但其它二个表数据少）

1. Sub CheryBTL_4() '<0.05s
   
2.     Dim i As Integer, j As Integer, m As Integer, t As Single
   
3.     Dim Mre As Integer, R1 As Integer, L1 As Integer
   
4.     Dim ar1, ar2, ar3, re(1 To 500, 1 To 3) As Single
   
5.     Dim d1 As Object, d2 As Object, d3 As Object
   
6.     t = Timer
   
7.     Application.ScreenUpdating = False
   
8.     Set d1 = CreateObject("Scripting.Dictionary")
   
9.     Set d2 = CreateObject("Scripting.Dictionary")
   
10.     Set d3 = CreateObject("Scripting.Dictionary")
    
11.     ar1 = Sheets(1).Range("A1").CurrentRegion
    
12.     ar2 = Sheets(2).Range("A1").CurrentRegion
    
13.     ar3 = Sheets(3).Range("A1").CurrentRegion
    
14.     For i = 2 To UBound(ar1) '确认工段表中的顺序
    
15.         If Not d2.exists(ar1(i, 1)) Then
    
16.             If ar1(i, 2) = "调整" Then
    
17.                 d1(ar1(i, 1)) = 2
    
18.             ElseIf ar1(i, 2) = "检查" Then
    
19.                 d1(ar1(i, 1)) = 3
    
20.             Else
    
21.                 d1(ar1(i, 1)) = 4
    
22.             End If
    
23.         End If
    
24.     Next i
    
25.     For i = 2 To UBound(ar2) '确认损失单价表中的顺序
    
26.         If Not d2.exists(ar2(i, 1)) Then
    
27.             d2(ar2(i, 1)) = i
    
28.         End If
    
29.     Next i
    
30.     For i = 2 To UBound(ar3)
    
31.         If Not d3.exists(ar3(i, 1)) Then
    
32.             m = m + 1
    
33.             d3(ar3(i, 1)) = m
    
34.         End If
    
35.         Mre = d3(ar3(i, 1)) '结果的列标
    
36.         R1 = d1(ar3(i, 2)) '结果的行标
    
37.         L1 = d2(ar3(i, 1)) 'Failure Code对应的列标
    
38.         re(Mre, R1 - 1) = re(Mre, R1 - 1) + ar2(L1, R1)
    
39.     Next i
    
40.     Sheets("结果").[a2].Resize(500, 4).ClearContents
    
41.     Sheets("结果").[a2].Resize(d3.Count) = Application.Transpose(d3.keys)
    
42.     Sheets("结果").[b2].Resize(500, 3) = re
    
43.     Application.ScreenUpdating = ture
    
44.     MsgBox Timer - t
    
45. End Sub

复制代码

hrpotter

1. Sub test()
   
2.     Dim arr, brr, crr, drr(1 To 10000, 1 To 3)
   
3.     Dim i As Long, j As Long, k As Long, m As Long, n As Long
   
4.     Dim d1, d2, d3, t As Single
   
5.     t = Timer
   
6.     Set d1 = CreateObject("scripting.dictionary")
   
7.     Set d2 = CreateObject("scripting.dictionary")
   
8.     Set d3 = CreateObject("scripting.dictionary")
   
9.     arr = Sheet3.Range("a1").CurrentRegion
   
10.     For i = 2 To UBound(arr)
    
11.         If arr(i, 2) = "调整" Then
    
12.             d1(arr(i, 1)) = 1
    
13.         ElseIf arr(i, 2) = "检查" Then
    
14.             d1(arr(i, 1)) = 2
    
15.         Else
    
16.             d1(arr(i, 1)) = 3
    
17.         End If
    
18.     Next
    
19.     brr = Sheet2.Range("a1").CurrentRegion
    
20.     For i = 2 To UBound(brr)
    
21.         d2(brr(i, 1)) = i
    
22.     Next
    
23.     crr = Sheet1.Range("a1").CurrentRegion
    
24.     For i = 2 To UBound(crr)
    
25.         If Not d3.exists(crr(i, 1)) Then
    
26.             k = k + 1
    
27.             d3(crr(i, 1)) = k
    
28.         End If
    
29.         m = d2(crr(i, 1))
    
30.         n = d1(crr(i, 2))
    
31.         j = d3(crr(i, 1))
    
32.         drr(j, n) = drr(j, n) + brr(m, n + 1)
    
33.     Next
    
34.     With Sheet4
    
35.         .Range("a2:d65536").ClearContents
    
36.         .Range("a2").Resize(k, 1) = Application.Transpose(d3.keys)
    
37.         .Range("b2").Resize(k, 3) = drr
    
38.     End With
    
39.     MsgBox Timer - t
    
40. End Sub

复制代码

Sellby

用了好多字典，自测0.0625

1. Sub sellby()
   
2.     Dim arr, brr, crr, drr(1 To 60000, 1 To 4), tmpArr
   
3.     Dim d1 As New Dictionary, d2 As New Dictionary
   
4.     Dim d3 As New Dictionary, dic As New Dictionary
   
5.     Dim i%, j%, n%, k%, x As Byte
   
6.     Dim PNo$, Code$
   
7.     Dim t
   
8.     t = Timer
   
9.     arr = Sheets("工段表").UsedRange
   
10.     brr = Sheets("损失单价表").UsedRange
    
11.     crr = Sheets("数据源").UsedRange
    
12.     For i = 2 To UBound(arr)
    
13.         If Not d1.Exists(arr(i, 1)) Then d1.Add arr(i, 1), arr(i, 2)
    
14.     Next i
    
15.     For i = 2 To UBound(brr)
    
16.         If Not d2.Exists(brr(i, 1)) Then d2.Add brr(i, 1), Array(brr(i, 2), brr(i, 3), brr(i, 4))
    
17.     Next i
    
18.     d3.Add brr(1, 2), 0
    
19.     d3.Add brr(1, 3), 1
    
20.     d3.Add brr(1, 4), 2
    
21.     n = 1
    
22.     drr(1, 1) = brr(1, 1)
    
23.     drr(1, 2) = brr(1, 2)
    
24.     drr(1, 3) = brr(1, 3)
    
25.     drr(1, 4) = brr(1, 4)
    
26.     For i = 2 To UBound(crr)
    
27.         PNo = crr(i, 1)
    
28.         Code = crr(i, 2)
    
29.         tmpArr = d2(PNo)
    
30.         x = d3(d1(Code))
    
31.        If Not dic.Exists(PNo) Then
    
32.             n = n + 1
    
33.             dic.Add PNo, n
    
34.             k = dic(PNo)
    
35.             drr(k, 1) = PNo
    
36.             drr(k, x + 2) = tmpArr(x)
    
37.         Else
    
38.             k = dic(PNo)
    
39.             drr(k, x + 2) = drr(k, x + 2) + tmpArr(x)
    
40.         End If
    
41.     Next i
    
42.     With Sheets("结果")
    
43.         .Cells.ClearContents
    
44.         .Range("a1").Resize(dic.Count + 1, 4) = drr
    
45.     End With
    
46.     Set d1 = Nothing
    
47.     Set d2 = Nothing
    
48.     Set d3 = Nothing
    
49.     Set dic = Nothing
    
50.     MsgBox Timer - t
    
51. End Sub
    

复制代码

xdragon

1. Sub xdragon()
   
2. Application.ScreenUpdating = False
   
3. Dim arr, brr, crr, rn As Long, dic1 As Object, dic2 As Object, dic3 As Object, i As Long, j As Byte, t As Single
   
4. t = Timer
   
5. With Sheets("数据源")
   
6.   rn = .Cells(Rows.Count, 1).End(3).Row
   
7.   arr = .Range("A1:B" & rn)
   
8. End With
   
9. With Sheets("工段表")
   
10.   rn = .Cells(Rows.Count, 1).End(3).Row
    
11.   brr = .Range("A1:B" & rn)
    
12. End With
    
13. With Sheets("损失单价表")
    
14.   rn = .Cells(Rows.Count, 1).End(3).Row
    
15.   crr = .Range("A1:D" & rn)
    
16. End With
    
17. Set dic1 = CreateObject("scripting.dictionary")
    
18.   For i = 2 To UBound(brr)
    
19.     dic1(brr(i, 1) & "|" & brr(i, 2)) = 1
    
20.   Next
    
21. Set dic3 = CreateObject("scripting.dictionary")
    
22. Set dic2 = CreateObject("scripting.dictionary")
    
23. With Sheets("结果")
    
24. .Cells.ClearContents
    
25.   For j = 2 To 4
    
26.     dic3.RemoveAll
    
27.     For i = 2 To UBound(crr)
    
28.       dic3(crr(i, 1)) = crr(i, j)
    
29.     Next
    
30.     dic2.RemoveAll
    
31.     For i = 2 To UBound(arr)
    
32.       dic2(arr(i, 1)) = dic2(arr(i, 1)) + dic1(arr(i, 2) & "|" & crr(1, j)) * dic3(arr(i, 1))
    
33.     Next
    
34.     .Range("B2:B" & dic2.Count + 1).Offset(0, j - 2) = Application.Transpose(dic2.items)
    
35.   Next
    
36.   .Range("A2:A" & dic2.Count + 1) = Application.Transpose(dic2.keys)
    
37.   .Range("A1:D1") = Array("PART NO.", "调整", "检查", "外观")
    
38. End With
    
39. Application.ScreenUpdating = True
    
40. MsgBox Format(Round(Timer - t, 3), "0.000")
    
41. End Sub

复制代码

交作业了。

sklzz888

啊？

开心妙妙

热身题查找汇总练习-开心妙妙1.rar (257.34 KB, 下载次数: 7)

2013-10-19 18:55 上传

点击文件名下载附件
也许只有我才会交这种未完成的代码
{:011:}

hoogle

1. Sub hoogle()
   
2. '前期绑定字典
   
3. t = Timer
   
4. Dim 损失单价表, 工段表, 数据源, arrRes(1 To 10000, 1 To 4)
   
5. Dim i As Integer, j As Integer, k As Integer, Temp As Single, Tempbyte As Byte
   
6. 工段表 = Sheets("工段表").Range("a1").Range("a1").CurrentRegion
   
7. 损失单价表 = Sheets("损失单价表").Range("a1").Range("a1").CurrentRegion
   
8. 数据源 = Sheets("数据源").Range("a1").Range("a1").CurrentRegion
   
9. Dim 单价 As New dictionary
   
10. Dim d As New dictionary
    
11. For i = 2 To UBound(损失单价表)
    
12.     单价(损失单价表(i, 1)) = 损失单价表(i, 2) & "|" & 损失单价表(i, 3) & "|" & 损失单价表(i, 4)
    
13. Next
    
14. For i = 2 To UBound(数据源)
    
15.     If Not d.Exists(数据源(i, 1)) Then
    
16.         k = k + 1
    
17.         d(数据源(i, 1)) = k
    
18.         arrRes(k, 1) = 数据源(i, 1)
    
19.     End If
    
20.     For j = 2 To UBound(工段表)
    
21.         If 工段表(j, 1) = 数据源(i, 2) Then
    
22.             Tempbyte = InStr("0调整检查外观", 工段表(j, 2))
    
23.             Temp = Val(Split(单价(数据源(i, 1)), "|")(Tempbyte / 2 - 1))
    
24.             arrRes(d(数据源(i, 1)), Tempbyte / 2 + 1) = arrRes(d(数据源(i, 1)), (Tempbyte) / 2 + 1) + Temp
    
25.             Exit For
    
26.         End If
    
27.     Next
    
28. Next
    
29. With Sheets("结果")
    
30.   .UsedRange.Offset(1).ClearContents
    
31.   .Range("a2").Resize(UBound(arrRes), UBound(arrRes, 2)) = arrRes
    
32. End With
    
33. Debug.Print Timer - t
    
34. End Sub

复制代码