|
|
Sub 查询()
Dim ar As Variant
Dim arr(), crr()
With Sheets("出库统计表")
rs = .Cells(Rows.Count, 1).End(xlUp).Row
If rs < 2 Then MsgBox "出库统计表为空，请先录入数据": End
ar = .Range("a1:o" & rs)
End With
With Sheets("明细查询")
rr = Array(.[b2], .[b2].Address, 1, .[d2], .[d2].Address, 2, .[f2], .[f2].Address, 2, .[h2], .[h2].Address, 6, .[j2], .[j2].Address, 7, .[l2], .[l2].Address, 3)
ReDim crr(1 To 6, 1 To 3)
For i = 0 To UBound(rr) Step 3
If Trim(rr(i)) <> "" Then
n = n + 1
crr(n, 1) = rr(i)
crr(n, 2) = rr(i + 1)
crr(n, 3) = rr(i + 2)
End If
Next i
If n = "" Then MsgBox "查询条件为空，请录入查询条件！": End
ReDim arr(1 To UBound(ar), 1 To UBound(ar, 2))
For i = 3 To UBound(ar)
gs = 0
For s = 1 To n
zd = crr(s, 1)
dz = crr(s, 2)
lh = crr(s, 3)
If dz = "$D$2" Then
If DateValue(ar(i, lh)) >= DateValue(zd) Then
gs = gs + 1
End If
ElseIf dz = "$F$2" Then
If DateValue(ar(i, lh)) <= DateValue(zd) Then
gs = gs + 1
End If
Else
If Trim(ar(i, lh)) = Trim(zd) Then
gs = gs + 1
End If
End If
Next s
If gs = n Then
m = m + 1
For j = 1 To UBound(ar, 2)
arr(m, j) = ar(i, j)
Next j
End If
Next i
If m = "" Then MsgBox "没有符合条件的数据！": End
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r > 4 Then .Range("a5:n" & r) = Empty
.[a5].Resize(m, UBound(arr, 2)) = arr
End With
MsgBox "ok!"
End Sub
|
|
楼主: zxf372188
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2022-7-16 18:41
路过学习一下 谢谢
