|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Option Explicit
Sub test()
Dim i, j, k, arr, brr, sht, crr, n, m
brr = Sheets("查询表").[a3:y3]
sht = Split("数据库1 数据库2")
For i = 0 To UBound(sht)
With Sheets(sht(i))
crr = .Range("b2:z" & .Cells(Rows.Count, "b").End(xlUp).Row)
If i = 0 Then ReDim arr(1 To 10 ^ 4, 1 To UBound(crr, 2))
For j = 1 To UBound(crr, 1)
n = n + 1
For k = 1 To UBound(crr, 2)
arr(n, k) = crr(j, k)
Next k, j
End With
Next
For i = 1 To n
For j = 1 To UBound(brr, 2)
If Len(brr(1, j)) > 0 And brr(1, j) = arr(i, j) Then '满足一项即可,自己修改
m = m + 1
For k = 1 To UBound(brr, 2): arr(m, k) = arr(i, k): Next
Exit For
End If
Next j, i
With Sheets("查询表").[a6]
.Resize(10 ^ 4, UBound(arr, 2)).ClearContents
If m > 0 Then .Resize(m, UBound(arr, 2)) = arr
End With
End Sub |
|