excelflower 这朵花还是很聪明的，也很有条理，设计的 个人查询，人员表 这两张表格式真的不错。
下面的这段是 全字典+数组，不用表格排序的，速度比上次慢一点，但也控制在1秒内
，代码放 在 查询表 中
Sub main2()
t = Timer
Application.ScreenUpdating = False
Dim i&, j&, Arr, Brr, strs As String, crr()
Dim dic As Object, strn As String
Dim strp As String
Set dic = CreateObject("scripting.dictionary")
With Sheets("齿数与生产单价")
Brr = .Range("a2:b" & .[a65536].End(3).Row)
For i = 1 To UBound(Brr)
dic(Brr(i, 1)) = Brr(i, 2)
Next i
End With
With Sheets("原始生产数据清单")
Arr = .Range("a2:o" & .[a65536].End(3).Row)
ReDim crr(1 To UBound(Arr), 1 To 11)
For i = 1 To UBound(Arr)
strn = Left(Arr(i, 5), 1)
strs = Arr(i, 3) & "," & Arr(i, 4) & "," & Arr(i, 8)
If Not dic.exists(strs) Then
k = k + 1
dic(strs) = k
crr(k, 1) = Arr(i, 3)
crr(k, 2) = Arr(i, 4)
crr(k, 3) = Arr(i, 8)
If dic.exists(Arr(i, 8)) Then
crr(k, 7) = dic(Arr(i, 8))
Else
crr(k, 7) = Arr(i, 9) '有可能在字典中没有，以防万一
End If
crr(k, 9) = strn
End If
crr(dic(strs), 4) = crr(dic(strs), 4) + Arr(i, 11)
crr(dic(strs), 5) = crr(dic(strs), 5) + Arr(i, 12)
crr(dic(strs), 6) = crr(dic(strs), 6) + Arr(i, 13)
crr(dic(strs), 8) = crr(dic(strs), 8) + Arr(i, 14)
strp = Arr(i, 3) & "," & strn
dic(strp) = dic(strp) + Arr(i, 14)
dic(Arr(i, 3)) = dic(Arr(i, 3)) + Arr(i, 14)
Next i
For i = k To 1 Step -1
If Not dic.exists(crr(i, 1) & ",") Then
crr(i, 11) = dic(crr(i, 1))
dic(crr(i, 1) & ",") = ""
End If
If Not dic.exists(crr(i, 1) & "'" & crr(i, 9)) Then
crr(i, 10) = dic(crr(i, 1) & "," & crr(i, 9))
dic(crr(i, 1) & "'" & crr(i, 9)) = ""
End If
Next
End With
With Sheets("查询表")
.Range("m3:am20000").ClearContents
.Range("m3").Resize(k, 11) = crr
.Range("m3:w" & UBound(Arr) + 1).Borders.LineStyle = 1
Application.ScreenUpdating = True
.Range("q1") = Timer - t
End With
End Sub
[ 本帖最后由 office2008 于 2010-12-9 19:46 编辑 ] |
楼主: ljy688
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2010-12-9 19:36
楼主
