跨工作簿查询汇总

jurdy001

快速查询汇总 文件中有网上找的代码 但是工作簿多了 就汇总不全

工作簿多（大概50个） 每个表数据约1000个
求助老师优化代码 或给个新的可行代码
谢谢老师

jurdy001

代码在文件夹里的 工作簿1里面   汇总也是汇到里面   按人名汇总   不用去重

jurdy001

代码在工作簿1里面   汇总也在里面  不用去重    需要汇总的列： 姓名,学号,报名年级,报名时间,实际缴纳,工作簿名称（ 每行后附上该条数据所在工作簿名称）

fzxba

1. Sub test1() '。
   
2.   Dim Conn As Object, Dict As Object, Cel As Range, strConn As String
   
3.   Dim p As String, f As String, s As String, SQL As String
   
4.   
   
5.   Application.ScreenUpdating = False
   
6.   Set Cel = Sheet3.Range("A2")
   
7.   Cel.Resize(12345, 6).ClearContents
   
8.   
   
9.   Set Dict = CreateObject("Scripting.Dictionary")
   
10.   Set Conn = CreateObject("ADODB.Connection")
    
11.   s = "Excel 12.0;HDR=yes;Database="
    
12.   If Application.Version < 12 Then
    
13.     s = Replace(s, "12.0", "8.0")
    
14.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=yes';Data Source="
    
15.   Else
    
16.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';Data Source="
    
17.   End If
    
18.   Conn.Open strConn & ThisWorkbook.FullName
    
19.   p = ThisWorkbook.Path & "\学期终版备份\"
    
20.   f = Dir(p & "*.xls?")
    
21.   SQL = "SELECT 姓名,学号,报名年级,报名时间,实际缴纳,'[f]' AS 工作簿 FROM [" & s & p & "[f]].[人财报表$B1:AF] WHERE 姓名='" & Sheet1.Range("E3").Value & "'"
    
22.   Do
    
23.     If f <> ThisWorkbook.Name Then
    
24.       Dict.Add Replace(SQL, "[f]", f), vbNullString
    
25.       If Dict.Count = 49 Then
    
26.         Cel.CopyFromRecordset Conn.Execute(Join(Dict.Keys, " UNION ALL "))
    
27.         Dict.RemoveAll
    
28.         Set Cel = Cel.End(xlDown).Offset(1)
    
29.       End If
    
30.     End If
    
31.     f = Dir
    
32.   Loop While Len(f)
    
33.   If Dict.Count Then Cel.CopyFromRecordset Conn.Execute(Join(Dict.Keys, " UNION ALL "))
    
34.   
    
35.   Conn.Close
    
36.   Set Conn = Nothing
    
37.   Set Cel = Nothing
    
38.   Set Dict = Nothing
    
39.   
    
40.   Application.ScreenUpdating = True
    
41.   Beep
    
42. End Sub

复制代码

gwjkkkkk

请解压后使用。。。

xiaoyuemt

里面的循环只有16个文件，原代码可能是多个工作薄、多个工作表，把循环改改就好了，这样就不限制汇表的个数了。

jurdy001

fzxba 发表于 2022-12-28 18:44

有合并单元格 导致无法正常运行  相对而言 原代码好些

jurdy001

gwjkkkkk 发表于 2022-12-28 18:48
请解压后使用。。。

有屏闪  相对而言 原代码好些

jurdy001

xiaoyuemt 发表于 2022-12-28 18:48
里面的循环只有16个文件，原代码可能是多个工作薄、多个工作表，把循环改改就好了，这样就不限制汇表的个数 ...

简单 高效 可靠  谢谢点拨

jurdy001

xiaoyuemt 发表于 2022-12-28 18:48
里面的循环只有16个文件，原代码可能是多个工作薄、多个工作表，把循环改改就好了，这样就不限制汇表的个数 ...

老师 能否帮忙加个功能  
在生成汇总结果时 按照工作簿名称 倒序配列数据 比如
学而思2018-4工作簿
学而思2018-3工作簿
学而思2018-2工作簿
学而思2018-1工作簿
学而思2017-4工作簿
学而思2017-3工作簿