【VBA字典数组201301班】课前热身习题二
本帖最后由 sliang28 于 2013-10-22 15:05 编辑18点35分前下载附件前的同学请重新下载,由于我的失误,附件结果表有误{:212:}
此题目为查找汇总数据!方法不限,拼的就是时间{:3912:}
本次不给目标时间,结果是我用函数做的,不知道要多少时间.
当然你们不许用函数.{:2312:}
快来下载吧,比起习题一应该简单了好多.
备注:上交是只贴出代码即可,代码中不要改工作表的名称. 本帖最后由 fffox 于 2013-10-17 08:50 编辑
不要贴代码吗？
那就删代码传附件，请老师评点！ 本帖最后由 CheryBTL 于 2013-10-17 09:00 编辑
终于有结果了，中间的转换搞了1个多小时，0.22S：Sub CheryBTL()
Dim i As Integer, j As Integer, m As Integer, t As Single
Dim Mre As Integer, R1 As Integer, L1 As Integer
Dim ar1, ar2, ar3, re(1 To 500, 1 To 3) As Single, temp(1 To 500)
Dim d As Object, d2 As Object
t = Timer
Set d = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
ar1 = Sheets(1).Range("A1").CurrentRegion
ar2 = Sheets(2).Range("A1").CurrentRegion
ar3 = Sheets(3).Range("A1").CurrentRegion
For i = 2 To UBound(ar3)
If Not d.exists(ar3(i, 1)) Then
m = m + 1
d(ar3(i, 1)) = m
For j = 2 To UBound(ar2)
If ar3(i, 1) = ar2(j, 1) Then'求出Part.No对应的行标
temp(m) = j
Exit For
End If
Next j
End If
If Not d2.exists(ar3(i, 2)) Then
For j = 2 To UBound(ar1) 'FAILURE CODE对应的列
If ar1(j, 1) = ar3(i, 2) Then
If ar1(j, 2) = "调整" Then
d2(ar3(i, 2)) = 2
ElseIf ar1(j, 2) = "检查" Then
d2(ar3(i, 2)) = 3
Else
d2(ar3(i, 2)) = 4
End If
Exit For
End If
Next j
End If
Mre = d(ar3(i, 1)) '结果的列标
L1 = temp(Mre)'结果的行标
R1 = d2(ar3(i, 2)) 'Failure Code对应的列标
re(Mre, R1 - 1) = re(Mre, R1 - 1) + ar2(L1, R1)
Next i
Sheets("结果")..Resize(d.Count) = Application.Transpose(d.keys)
Sheets("结果")..Resize(500, 3) = re
MsgBox Timer - t
End Sub
本帖最后由 CheryBTL 于 2013-10-17 10:55 编辑
法2将第二个字典提前找好位置，对随机数据应该会减小总的循环次数，数据多时就不一定管用了：Sub CheryBTL_2() '0.139s
Dim i As Integer, j As Integer, m As Integer, t As Single
Dim Mre As Integer, R1 As Integer, L1 As Integer
Dim ar1, ar2, ar3, re(1 To 500, 1 To 3) As Single, temp(1 To 500)
Dim d As Object, d2 As Object
t = Timer
Set d = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
ar1 = Sheets(1).Range("A1").CurrentRegion
ar2 = Sheets(2).Range("A1").CurrentRegion
ar3 = Sheets(3).Range("A1").CurrentRegion
For i = 2 To UBound(ar1)
If Not d2.exists(ar1(i, 1)) Then
If ar1(i, 2) = "调整" Then
d2(ar1(i, 1)) = 2
ElseIf ar1(i, 2) = "检查" Then
d2(ar1(i, 1)) = 3
Else
d2(ar1(i, 1)) = 4
End If
End If
Next i
For i = 2 To UBound(ar3)
If Not d.exists(ar3(i, 1)) Then
m = m + 1
d(ar3(i, 1)) = m
For j = 2 To UBound(ar2)
If ar3(i, 1) = ar2(j, 1) Then'求出Part.No对应的行标
temp(m) = j
Exit For
End If
Next j
End If
Mre = d(ar3(i, 1)) '结果的列标
L1 = temp(Mre)'结果的行标
R1 = d2(ar3(i, 2)) 'Failure Code对应的列标
re(Mre, R1 - 1) = re(Mre, R1 - 1) + ar2(L1, R1)
Next i
Sheets("结果")..Resize(d.Count) =Application.Transpose(d.keys)
Sheets("结果")..Resize(500, 3) = re
MsgBox Timer - t
End Sub增加屏幕更新和赋值前清空数据，跑到了：0.125s：Sub CheryBTL_3() '0.125s
Dim i As Integer, j As Integer, m As Integer, t As Single
Dim Mre As Integer, R1 As Integer, L1 As Integer
Dim ar1, ar2, ar3, re(1 To 500, 1 To 3) As Single, temp(1 To 500)
Dim d As Object, d2 As Object
t = Timer
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
ar1 = Sheets(1).Range("A1").CurrentRegion
ar2 = Sheets(2).Range("A1").CurrentRegion
ar3 = Sheets(3).Range("A1").CurrentRegion
For i = 2 To UBound(ar1)
If Not d2.exists(ar1(i, 1)) Then
If ar1(i, 2) = "调整" Then
d2(ar1(i, 1)) = 2
ElseIf ar1(i, 2) = "检查" Then
d2(ar1(i, 1)) = 3
Else
d2(ar1(i, 1)) = 4
End If
End If
Next i
For i = 2 To UBound(ar3)
If Not d.exists(ar3(i, 1)) Then
m = m + 1
d(ar3(i, 1)) = m
For j = 2 To UBound(ar2)
If ar3(i, 1) = ar2(j, 1) Then'求出Part.No对应的行标
temp(m) = j
Exit For
End If
Next j
End If
Mre = d(ar3(i, 1)) '结果的列标
L1 = temp(Mre)'结果的行标
R1 = d2(ar3(i, 2)) 'Failure Code对应的列标
re(Mre, R1 - 1) = re(Mre, R1 - 1) + ar2(L1, R1)
Next i
Sheets("结果")..Resize(500, 4).ClearContents
Sheets("结果")..Resize(d.Count) = Application.Transpose(d.keys)
Sheets("结果")..Resize(500, 3) = re
Application.ScreenUpdating = ture
MsgBox Timer - t
End Sub使用三个字典，就快多了（主要原因还是因为源数据多，但其它二个表数据少）Sub CheryBTL_4() '<0.05s
Dim i As Integer, j As Integer, m As Integer, t As Single
Dim Mre As Integer, R1 As Integer, L1 As Integer
Dim ar1, ar2, ar3, re(1 To 500, 1 To 3) As Single
Dim d1 As Object, d2 As Object, d3 As Object
t = Timer
Application.ScreenUpdating = False
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set d3 = CreateObject("Scripting.Dictionary")
ar1 = Sheets(1).Range("A1").CurrentRegion
ar2 = Sheets(2).Range("A1").CurrentRegion
ar3 = Sheets(3).Range("A1").CurrentRegion
For i = 2 To UBound(ar1) '确认工段表中的顺序
If Not d2.exists(ar1(i, 1)) Then
If ar1(i, 2) = "调整" Then
d1(ar1(i, 1)) = 2
ElseIf ar1(i, 2) = "检查" Then
d1(ar1(i, 1)) = 3
Else
d1(ar1(i, 1)) = 4
End If
End If
Next i
For i = 2 To UBound(ar2) '确认损失单价表中的顺序
If Not d2.exists(ar2(i, 1)) Then
d2(ar2(i, 1)) = i
End If
Next i
For i = 2 To UBound(ar3)
If Not d3.exists(ar3(i, 1)) Then
m = m + 1
d3(ar3(i, 1)) = m
End If
Mre = d3(ar3(i, 1)) '结果的列标
R1 = d1(ar3(i, 2)) '结果的行标
L1 = d2(ar3(i, 1)) 'Failure Code对应的列标
re(Mre, R1 - 1) = re(Mre, R1 - 1) + ar2(L1, R1)
Next i
Sheets("结果")..Resize(500, 4).ClearContents
Sheets("结果")..Resize(d3.Count) = Application.Transpose(d3.keys)
Sheets("结果")..Resize(500, 3) = re
Application.ScreenUpdating = ture
MsgBox Timer - t
End Sub Sub test()
Dim arr, brr, crr, drr(1 To 10000, 1 To 3)
Dim i As Long, j As Long, k As Long, m As Long, n As Long
Dim d1, d2, d3, t As Single
t = Timer
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d3 = CreateObject("scripting.dictionary")
arr = Sheet3.Range("a1").CurrentRegion
For i = 2 To UBound(arr)
If arr(i, 2) = "调整" Then
d1(arr(i, 1)) = 1
ElseIf arr(i, 2) = "检查" Then
d1(arr(i, 1)) = 2
Else
d1(arr(i, 1)) = 3
End If
Next
brr = Sheet2.Range("a1").CurrentRegion
For i = 2 To UBound(brr)
d2(brr(i, 1)) = i
Next
crr = Sheet1.Range("a1").CurrentRegion
For i = 2 To UBound(crr)
If Not d3.exists(crr(i, 1)) Then
k = k + 1
d3(crr(i, 1)) = k
End If
m = d2(crr(i, 1))
n = d1(crr(i, 2))
j = d3(crr(i, 1))
drr(j, n) = drr(j, n) + brr(m, n + 1)
Next
With Sheet4
.Range("a2:d65536").ClearContents
.Range("a2").Resize(k, 1) = Application.Transpose(d3.keys)
.Range("b2").Resize(k, 3) = drr
End With
MsgBox Timer - t
End Sub 用了好多字典，自测0.0625Sub sellby()
Dim arr, brr, crr, drr(1 To 60000, 1 To 4), tmpArr
Dim d1 As New Dictionary, d2 As New Dictionary
Dim d3 As New Dictionary, dic As New Dictionary
Dim i%, j%, n%, k%, x As Byte
Dim PNo$, Code$
Dim t
t = Timer
arr = Sheets("工段表").UsedRange
brr = Sheets("损失单价表").UsedRange
crr = Sheets("数据源").UsedRange
For i = 2 To UBound(arr)
If Not d1.Exists(arr(i, 1)) Then d1.Add arr(i, 1), arr(i, 2)
Next i
For i = 2 To UBound(brr)
If Not d2.Exists(brr(i, 1)) Then d2.Add brr(i, 1), Array(brr(i, 2), brr(i, 3), brr(i, 4))
Next i
d3.Add brr(1, 2), 0
d3.Add brr(1, 3), 1
d3.Add brr(1, 4), 2
n = 1
drr(1, 1) = brr(1, 1)
drr(1, 2) = brr(1, 2)
drr(1, 3) = brr(1, 3)
drr(1, 4) = brr(1, 4)
For i = 2 To UBound(crr)
PNo = crr(i, 1)
Code = crr(i, 2)
tmpArr = d2(PNo)
x = d3(d1(Code))
If Not dic.Exists(PNo) Then
n = n + 1
dic.Add PNo, n
k = dic(PNo)
drr(k, 1) = PNo
drr(k, x + 2) = tmpArr(x)
Else
k = dic(PNo)
drr(k, x + 2) = drr(k, x + 2) + tmpArr(x)
End If
Next i
With Sheets("结果")
.Cells.ClearContents
.Range("a1").Resize(dic.Count + 1, 4) = drr
End With
Set d1 = Nothing
Set d2 = Nothing
Set d3 = Nothing
Set dic = Nothing
MsgBox Timer - t
End Sub
Sub xdragon()
Application.ScreenUpdating = False
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
t = Timer
With Sheets("数据源")
rn = .Cells(Rows.Count, 1).End(3).Row
arr = .Range("A1:B" & rn)
End With
With Sheets("工段表")
rn = .Cells(Rows.Count, 1).End(3).Row
brr = .Range("A1:B" & rn)
End With
With Sheets("损失单价表")
rn = .Cells(Rows.Count, 1).End(3).Row
crr = .Range("A1:D" & rn)
End With
Set dic1 = CreateObject("scripting.dictionary")
For i = 2 To UBound(brr)
dic1(brr(i, 1) & "|" & brr(i, 2)) = 1
Next
Set dic3 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
With Sheets("结果")
.Cells.ClearContents
For j = 2 To 4
dic3.RemoveAll
For i = 2 To UBound(crr)
dic3(crr(i, 1)) = crr(i, j)
Next
dic2.RemoveAll
For i = 2 To UBound(arr)
dic2(arr(i, 1)) = dic2(arr(i, 1)) + dic1(arr(i, 2) & "|" & crr(1, j)) * dic3(arr(i, 1))
Next
.Range("B2:B" & dic2.Count + 1).Offset(0, j - 2) = Application.Transpose(dic2.items)
Next
.Range("A2:A" & dic2.Count + 1) = Application.Transpose(dic2.keys)
.Range("A1:D1") = Array("PART NO.", "调整", "检查", "外观")
End With
Application.ScreenUpdating = True
MsgBox Format(Round(Timer - t, 3), "0.000")
End Sub交作业了。:lol 啊？
也许只有我才会交这种未完成的代码
{:011:} Sub hoogle()
'前期绑定字典
t = Timer
Dim 损失单价表, 工段表, 数据源, arrRes(1 To 10000, 1 To 4)
Dim i As Integer, j As Integer, k As Integer, Temp As Single, Tempbyte As Byte
工段表 = Sheets("工段表").Range("a1").Range("a1").CurrentRegion
损失单价表 = Sheets("损失单价表").Range("a1").Range("a1").CurrentRegion
数据源 = Sheets("数据源").Range("a1").Range("a1").CurrentRegion
Dim 单价 As New dictionary
Dim d As New dictionary
For i = 2 To UBound(损失单价表)
单价(损失单价表(i, 1)) = 损失单价表(i, 2) & "|" & 损失单价表(i, 3) & "|" & 损失单价表(i, 4)
Next
For i = 2 To UBound(数据源)
If Not d.Exists(数据源(i, 1)) Then
k = k + 1
d(数据源(i, 1)) = k
arrRes(k, 1) = 数据源(i, 1)
End If
For j = 2 To UBound(工段表)
If 工段表(j, 1) = 数据源(i, 2) Then
Tempbyte = InStr("0调整检查外观", 工段表(j, 2))
Temp = Val(Split(单价(数据源(i, 1)), "|")(Tempbyte / 2 - 1))
arrRes(d(数据源(i, 1)), Tempbyte / 2 + 1) = arrRes(d(数据源(i, 1)), (Tempbyte) / 2 + 1) + Temp
Exit For
End If
Next
Next
With Sheets("结果")
.UsedRange.Offset(1).ClearContents
.Range("a2").Resize(UBound(arrRes), UBound(arrRes, 2)) = arrRes
End With
Debug.Print Timer - t
End Sub
页:
[1]
2