|
|
Sub 数据筛选()
Dim ar As Variant
Dim arr(), rr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("sheet1")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "数据源为空！": End
ar = .Range("a1:e" & r)
rs = .Cells(Rows.Count, 9).End(xlUp).Row
If rs < 2 Then MsgBox "筛选条件为空！": End
br = .Range("i1:l" & r)
End With
For i = 2 To UBound(br)
If br(i, 1) <> "" Then
zd = br(i, 1) & "|" & br(i, 2)
d(zd) = i
End If
Next i
ReDim rr(1 To UBound(ar))
For i = 2 To UBound(ar)
If ar(i, 1) = "一级物料" Then
m = m + 1
rr(m) = i
End If
Next i
m = m + 1
rr(m) = r + 1
ReDim arr(1 To UBound(ar), 1 To 5)
For i = 1 To m - 1
ks = rr(i)
js = rr(i + 1) - 1
zd = ar(ks, 2) & "|" & ar(ks, 3)
xh = d(zd)
If xh <> "" Then
For s = ks + 1 To js
zf = ar(s, 2) & "|" & ar(s, 3)
t = dc(zf)
If t = "" Then
k = k + 1
dc(zf) = k
t = k
For j = 2 To 4
arr(k, j - 1) = ar(s, j)
Next j
End If
arr(t, 4) = arr(t, 4) + ar(s, 5)
arr(t, 5) = arr(t, 4) * br(xh, 4)
Next s
End If
Next i
If k = "" Then MsgBox "没有符合条件的数据！": End
With Sheets("结果")
.[a1].CurrentRegion.Offset(1) = Empty
.[a2].Resize(k, UBound(arr, 2)) = arr
End With
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-7-31 08:55
