求大佬帮忙，我这里放了4个工作簿，实际上我有800+个，每个工作簿只有1页，我需要...

fzxba

菜鸟想学 发表于 2024-1-25 13:24
有几个科目编码太长，就查不到了，比如这个1462020101010201

菜鸟想学

ykcbf1100 发表于 2024-1-25 11:21
附件供参考。。。

老师，你这个可以快一点吗，我放了10个文件就有点慢了

菜鸟想学

ykcbf1100 发表于 2024-1-25 11:21
附件供参考。。。

老师，你这个还能快点吗，10个表速度就下来了

ykcbf1100

菜鸟想学 发表于 2024-1-25 13:44
老师，你这个还能快点吗，10个表速度就下来了

如果想更快，改用SQL吧。
你再看看其他老师的回复吧。

opiona

菜鸟想学 发表于 2024-1-25 13:31
老师，你这个可以快一点吗，我放了10个文件就有点慢了

先将所有文件 使用SQL提取全部数据 到一个工作表
这样以后查询, 方便,速度还快
如果 800个表有变化 则重新提取全部, 或者部分

否则每次查询800个文件, 即使是SQL 速度也快不到哪里去

飞天篮球猪

供参考...2000个示例文件查找，10秒左右，花点心思优化可以更快

cztanghao

建议用python来跑

lizhipei78

800个工作簿怎么都不可能快，建议还是汇总到一个工作簿中，再作查询

菜鸟想学

Sub ykcbf()
    Dim cnn As Object
    Dim SQL$, MyPath$, MyFile$, a, arr(), i%, ii%, t$, m%
    t = [c1]

    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.Offset(3).ClearContents
    MyPath = ThisWorkbook.Path & "\"
    MyFile = Dir(MyPath & "*.xls")
    Do While MyFile <> ""
        If MyFile <> ThisWorkbook.Name Then
            m = m + 1
            ReDim Preserve arr(1 To m)
            arr(m) = MyFile
        End If
        MyFile = Dir()
    Loop
    Set cnn = CreateObject("adodb.connection")
    cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & arr(1)
    For i = 1 To m Step 16
        SQL = ""
        For ii = i To i + 15
            If ii > m Then Exit For
            
                If Len(SQL) Then SQL = SQL & " union all "
                SQL = SQL & "select 科目编码,辅助核算,'" & Replace(arr(ii), ".xls", "") & "','" & "新的工作表$a3:f3000" & "' from [Excel 8.0;Database=" & MyPath & arr(ii) & "]." & "新的工作表$a3:f3000" & " where 科目编码='" & t & "'"
         
        Next
        [a65536].End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    Next
    cnn.Close
    Set cnn = Nothing
    Application.ScreenUpdating = True
    MsgBox Timer - tt
End Sub
我找了一个多工作簿多表的改了改运行不了，老师们能帮我看看么

菜鸟想学

多文件夹多工作簿多工作表查询
https://club.excelhome.net/thread-1329899-1-1.html
(出处: ExcelHome技术论坛)
Sub ykcbf()
    Dim cnn As Object
    Dim SQL$, MyPath$, MyFile$, a, arr(), i%, ii%, t$, m%
    t = [c1]

    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.Offset(3).ClearContents
    MyPath = ThisWorkbook.Path & "\"
    MyFile = Dir(MyPath & "*.xls")
    Do While MyFile <> ""
        If MyFile <> ThisWorkbook.Name Then
            m = m + 1
            ReDim Preserve arr(1 To m)
            arr(m) = MyFile
        End If
        MyFile = Dir()
    Loop
    Set cnn = CreateObject("adodb.connection")
    cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & arr(1)
    For i = 1 To m Step 16
        SQL = ""
        For ii = i To i + 15
            If ii > m Then Exit For
            
                If Len(SQL) Then SQL = SQL & " union all "
                SQL = SQL & "select 科目编码,辅助核算,'" & Replace(arr(ii), ".xls", "") & "','" & "新的工作表$a3:f3000" & "' from [Excel 8.0;Database=" & MyPath & arr(ii) & "]." & "新的工作表$a3:f3000" & " where 科目编码='" & t & "'"
         
        Next
        [a65536].End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    Next
    cnn.Close
    Set cnn = Nothing
    Application.ScreenUpdating = True
    MsgBox Timer - tt
End Sub
我对这个宏改了改不能用，老师们可以帮我看看吗