|
Sub chaxun()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ar As Variant, cr As Variant
Dim wb As Workbook
lj = ThisWorkbook.Path & "\"
f = Dir(lj & "数据.xls*")
If f = "" Then MsgBox "找不到数据源文件!": End
With ActiveSheet
ar = .Range("b5:n5")
ReDim br(1 To UBound(ar, 2), 1 To 2)
For j = 1 To UBound(ar, 2)
If ar(1, j) <> "" Then
n = n + 1
br(n, 1) = ar(1, j)
br(n, 2) = j
End If
Next j
If n = "" Then MsgBox "至少输入一个查询条件!": End
Set wb = Workbooks.Open(lj & f, 0)
With wb.Worksheets(1)
r = .Cells(Rows.Count, 2).End(xlUp).Row
cr = .Range("b4:n" & r)
End With
wb.Close False
ReDim arr(1 To UBound(cr), 1 To UBound(cr, 2))
For i = 2 To UBound(cr)
sl = 0
For s = 1 To n
lh = br(s, 2)
If cr(i, lh) = br(s, 1) Then
sl = sl + 1
End If
Next s
If sl = n Then
m = m + 1
For j = 1 To UBound(cr, 2)
arr(m, j) = cr(i, j)
Next j
End If
Next i
If m = "" Then MsgBox "没有符合条件的数据!": End
.UsedRange.Offset(7) = Empty
.[b8].Resize(m, UBound(arr, 2)) = arr
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub |
|