垮工作表查找数据（数据量有点大）

天真无鞋

在清单工作表，获取局域网地址打开TEST文件地址，查找数据库1和数据库2工作簿的测试工作表F列，当清单工作表B2输入的字符与查找F列字符相同，全部复制到清单工作表，详见附件。

lisongmei

用PQ合并后再用高级筛选，还是挺快的

ykcbf1100

参与一下。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.7.31
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ThisWorkbook.Sheets("清单")
   
5.     st = CStr(sh.[b2].Value)
   
6.     p = ThisWorkbook.Path & "\Test"
   
7.     ReDim brr(1 To 10000, 1 To 100)
   
8.     For Each f In fso.GetFolder(p).Files
   
9.         If LCase$(f.Name) Like "*.xls*" Then
   
10.             Set wb = Workbooks.Open(f, 0)
    
11.             With wb.Sheets("测试")
    
12.                 arr = .UsedRange
    
13.                 wb.Close False
    
14.             End With
    
15.             For i = 3 To UBound(arr)
    
16.                 If InStr(CStr(arr(i, 6)), st) Then
    
17.                     m = m + 1
    
18.                     For j = 1 To UBound(arr, 2)
    
19.                         brr(m, j) = arr(i, j)
    
20.                     Next
    
21.                 End If
    
22.             Next
    
23.         End If
    
24.     Next f
    
25.     With sh
    
26.         .[A4].Resize(10000, 100).ClearContents
    
27.         .[A4].Resize(m, UBound(arr, 2)) = brr
    
28.     End With
    
29.     Application.ScreenUpdating = True
    
30.     MsgBox "OK！"
    
31. End Sub
    

复制代码

quqiyuan

参与一下，供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Application.ScreenUpdating = False
    Set wb = ThisWorkbook
    p = wb.Path & "\Test\"
    f = Dir(p & "*.xls*")
    Set sht = wb.Sheets("清单")
    s = sht.[b2]
    ReDim brr(1 To 100000, 1 To 1000)
    Do While f <> ""
        With Workbooks.Open(p & f, 0).Sheets("测试")
            arr = .UsedRange
            For i = 3 To UBound(arr)
                If arr(i, 6) = s Then
                    n = n + 1
                    For j = 1 To UBound(arr, 2)
                        brr(n, j) = arr(i, j)
                    Next
                End If
            Next
            .Parent.Close 0
        End With
        f = Dir
    Loop
    sht.[a4].Resize(n, UBound(arr, 2)) = brr
    Application.ScreenUpdating = True
End Sub

天真无鞋

谢谢2位老师

qytjc

  For i = 3 To UBound(arr)   应该改为   For i = 2 To UBound(arr)  从第二行开始

天真无鞋

quqiyuan 发表于 2024-7-31 15:49
参与一下，供参考。。。

老师，能否从局域网地址获取文件在把对应数据复制过来，如果可以帮忙改一下代码，谢谢。