多工作表查询 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几秒就可以了 80多个工作簿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
|
|