|
|
这段程序就是 查询表中的，还可以修改
Sub main()
t = Timer
Application.ScreenUpdating = False
Dim i&, j&, Arr, Brr, s As String, crr()
Dim dic As Object
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)
'Arr(i, 15) = Left(Arr(i, 5), 1)
s = Arr(i, 3) & "/" & Arr(i, 4) & "/" & Arr(i, 8)
If Not dic.exists(s) Then
k = k + 1
dic(s) = 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) = Left(Arr(i, 5), 1)
End If
crr(dic(s), 4) = crr(dic(s), 4) + Arr(i, 11)
crr(dic(s), 5) = crr(dic(s), 5) + Arr(i, 12)
crr(dic(s), 6) = crr(dic(s), 6) + Arr(i, 13)
crr(dic(s), 8) = crr(dic(s), 8) + Arr(i, 14)
Next i
End With
With Sheets("查询表")
.Range("m3:am20000").ClearContents
.Range("m3").Resize(k, 11) = crr
.Range("m3").Resize(k, 11).Sort Key1:=Range("M3"), Order1:=xlAscending, Key2:=Range("u3") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1
Arr = .Range("m3:w" & .[m65536].End(3).Row + 1)
For i = 2 To UBound(Arr)
X = X + Arr(i - 1, 8)
Y = Y + Arr(i - 1, 8)
If Arr(i - 1, 1) <> Arr(i, 1) Then
Arr(i - 1, 11) = Y
Y = 0
End If
If Arr(i, 1) & Arr(i, 9) <> Arr(i - 1, 1) & Arr(i - 1, 9) Then
Arr(i - 1, 10) = X
X = 0
End If
Next i
.[m3].Resize(UBound(Arr) - 1, 11) = Arr
.Range("m3:w" & UBound(Arr) + 1).Borders.LineStyle = 1
Application.ScreenUpdating = True
.Range("q1") = Timer - t
End With
End Sub |
|
楼主: ljy688
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2010-12-8 08:26
