多工作表查询
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False '关闭工作表事件
Sheets(1).Range("D5:F22") = "" '清空原有的数据
Dim x%, arr1, y%, MyStr$, arr2(1 To 100, 1 To 3)
Dim m%, n%, k%
MyStr = Sheets(1).Range("C5")
Application.ScreenUpdating = False '关闭屏幕刷新
For x = 2 To Sheets.Count '循环工作表,从第二个表开始
arr1 = Sheets(x).UsedRange '把工作表区域装到数组arr1里
For y = 2 To UBound(arr1, 1) '循环数组arr1的行
If arr1(y, 2) = MyStr Then '把数组arr1第2列的满足条件装到数组arr2
k = k + 1
For m = 1 To 3
arr2(k, m) = arr1(y, m + 2)
Next m
End If
If arr1(y, 7) = MyStr Then '把数组arr1第7列的满足条件装到数组arr2
k = k + 1
For n = 1 To 3
arr2(k, n) = arr1(y, n + 7)
Next n
End If
Next y
Next x
Application.ScreenUpdating = True '打开屏幕刷新
On Error GoTo 100 '由于所有的表里一个也不找不到,报错,跳到100
Sheets(1).[D5].Resize(k, 3) = arr2 '把数组arr2读出来
Application.EnableEvents = True '打开工作表事件
Exit Sub
100:
Application.EnableEvents = True
MsgBox "亲，不好意思，各个表里查不到" & MyStr, 64, "温馨提示——佛山小老鼠"
End Sub
多工作簿查询
先申请,这个代码速度是很慢的,没有用SQL和ADO结合起来那么快,如果工作簿不是很多可以接受,呵呵,大约30个工作簿以下吧,多了可能让人等的太久,如果用SQL和ADO几秒就可以了
如果想速度很快,请参考
zhaogang1960 版主出的竞赛题:
[Excel 程序开发] 【83期】VBA多工作簿多工作表数据查询[已小结]
http://club.excelhome.net/thread-781055-1-1.html80多个工作簿2秒多查询完毕
Option Explicit
Sub 查询()
Dim MyFile$, Wb As Workbook, x%, Zlast%, st$, arr2(1 To 10000, 1 To 5), z%
Dim arr1, k%, j%
Range("A2:F" & Rows.Count) = "" '清空原有的数据
MyFile = Dir(ThisWorkbook.Path & "\分表\*.*") '取得分表文件夹下任意一个文件名
st = ThisWorkbook.Sheets(1).[A1]
Do '循环文件夹里的文件
Set Wb = GetObject(ThisWorkbook.Path & "\分表\" & MyFile) '在后台打开工作簿且赋值给变量Wb
With Wb
For x = 1 To Wb.Sheets.Count '循环打开的工作簿里的工作表
arr1 = .Sheets(x).Range("A1").CurrentRegion.Offset(1) '把工作表区域数据装到数组arr1里
For j = 1 To UBound(arr1, 1) '循环数组arr1里的行
If arr1(j, 1) = st Then '判断是否和查询值相等
k = k + 1
For z = 2 To 6
arr2(k, z - 1) = arr1(x, z) '把数组arr1满足条件装到数组arr2里
Next z
End If
Next j
Next x
.Close True '关闭wb工作簿
End With
MyFile = Dir '第二次赋值不要参数,且自动找到下一个工作簿
Loop While MyFile <> ""
[B2].Resize(k, 5) = arr2 '把数组arr2读出来
End Sub
多工作簿查询.rar
