顶层文件夹及其子文件夹工作薄汇总

zllyyz

请教各位老师（自己弄的速度好慢...）：

需求一：在尽可能最快运行速度下将“文件夹及其多个子文件夹工作薄汇总”此文件夹(含本级)及其子文件夹（及其子文件夹里....多层子文件夹）指定工作薄(《待重设格式》)指定工作表里的《Sheet1》进行取消筛选、取消隐藏行列操作后保存文件

需求二、如能直接汇总多层文件夹里的指定工作薄(《待重设格式》)指定工作表里的《Sheet1》所有数据(含隐藏、筛选)到“汇总”此工作薄的《Sheet1》(标题栏只取第一个源表，其他表不取标题栏)，请直接忽略“需求一”


方式不限(SQL+ADO 或VBA 数组....)

ykcbf1100

fso+数组

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.4
   
2.     Dim fns(1 To 10000, 1 To 2), brr(1 To 10000, 1 To 14)
   
3.     Set fso = CreateObject("scripting.filesystemobject")
   
4.     Application.ScreenUpdating = False
   
5.     Dim tm: tm = Timer
   
6.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
7.     p = ThisWorkbook.Path & ""
   
8.     Set ff = fso.GetFolder(p)
   
9.     k = 0
   
10.     getfns ff, fns, k, fso
    
11.     For x = 1 To k
    
12.         Set wb = Workbooks.Open(fns(x, 2), 0)
    
13.         With wb.Sheets(1)
    
14.             .AutoFilterMode = False
    
15.             arr = .UsedRange
    
16.             wb.Close False
    
17.         End With
    
18.         For i = 1 To UBound(arr)
    
19.             If arr(i, 1) <> Empty Then
    
20.                 m = m + 1
    
21.                 For j = 1 To UBound(arr, 2)
    
22.                     brr(m, j) = arr(i, j)
    
23.                 Next
    
24.             End If
    
25.         Next
    
26.     Next
    
27.     With sh
    
28.         .Cells = ""
    
29.         .[a1].Resize(m, UBound(brr, 2)) = brr
    
30.         .[a1].Resize(m, UBound(brr, 2)).Borders.LineStyle = 1
    
31.     End With
    
32.     Application.ScreenUpdating = True
    
33.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
34. End Sub

复制代码

baofa2

据描述，真还是SQL做的事。

1. Sub Main() '补
   
2.   
   
3.   Dim strPath As String
   
4.   strPath = ThisWorkbook.Path & "\"
   
5.   
   
6.   Dim vrtFiles(1 To 2345) As String
   
7.   Dim Conn As Object, Dict As Object, Fso As Object
   
8.   Dim i As Integer, iCount As Integer, pos As Long
   
9.   Dim strConn As String, strSQL As String, s As String
   
10.   
    
11.   Cells.ClearContents
    
12.   DoApp False
    
13.   
    
14.   Set Dict = CreateObject("Scripting.Dictionary")
    
15.   Set Conn = CreateObject("ADODB.Connection")
    
16.   Set Fso = CreateObject("Scripting.FileSystemObject")
    
17.   
    
18.   s = "Excel 12.0;HDR=NO;IMEX=1;Database="
    
19.   If Application.Version < 12 Then 'Or InStr(Application.Path, "WPS")
    
20.     s = Replace(s, "12.0", "8.0")
    
21.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=NO';Data Source="
    
22.   Else
    
23.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=NO';Data Source="
    
24.   End If
    
25.   'Conn.Open strConn & ThisWorkbook.FullName
    
26.   
    
27.   GetFiles strPath, Fso, vrtFiles, iCount, ThisWorkbook.Name, "待重设格式.xls"
    
28.   For i = 1 To iCount
    
29.     If i = 1 Then Conn.Open strConn & vrtFiles(i)
    
30.     strSQL = "SELECT * FROM [" & s & vrtFiles(i) & "].[Sheet1$A" & 1 - CInt(i > 1) & ":N] WHERE F1 IS NOT NULL"
    
31.     Dict.Add strSQL, vbNullString
    
32.     If Dict.Count = 49 Then
    
33.       Range("A" & pos + 1).CopyFromRecordset Conn.Execute(Join(Dict.Keys, " UNION ALL "))
    
34.       pos = Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
    
35.       Dict.RemoveAll
    
36.     End If
    
37.   Next
    
38.   If Dict.Count Then Range("A" & pos + 1).CopyFromRecordset Conn.Execute(Join(Dict.Keys, " UNION ALL "))
    
39.   
    
40.   Conn.Close
    
41.   Set Conn = Nothing
    
42.   Set Dict = Nothing
    
43.   Set Fso = Nothing
    
44.   
    
45.   DoApp
    
46.   Beep
    
47. End Sub
    
48. 
    
49. Function GetFiles(strPath As String, objFso As Object, vrtFiles() As String, iCount As Integer, strExclude As String, Optional strFilter As String = ".xls")
    
50.   Dim objSubFolder As Object, objFilterFile As Object
    
51.   For Each objFilterFile In objFso.GetFolder(strPath).Files
    
52.     If InStr(LCase(objFilterFile.Name), strFilter) Then
    
53.       If InStr(objFilterFile.Name, strExclude) = 0 Then
    
54.         iCount = iCount + 1
    
55.         vrtFiles(iCount) = objFilterFile.Path
    
56.       End If
    
57.     End If
    
58.   Next
    
59.   For Each objSubFolder In objFso.GetFolder(strPath).SubFolders
    
60.     GetFiles objSubFolder.Path, objFso, vrtFiles, iCount, strExclude, strFilter
    
61.   Next
    
62. End Function
    
63. 
    
64. Function DoApp(Optional b As Boolean = True)
    
65.   With Application
    
66.     .ScreenUpdating = b
    
67.     .DisplayAlerts = b
    
68.     .Calculation = -b * 30 - 4135
    
69.   End With
    
70. End Function

复制代码

zllyyz

baofa2 发表于 2024-4-4 21:51
据描述，真还是SQL做的事。

同层的应该不难，有子层的不会写

baofa2

zllyyz 发表于 2024-4-4 22:18
同层的应该不难，有子层的不会写

SQL附件测试.zip (88.25 KB, 下载次数: 14)

2024-4-5 07:39 上传

点击文件名下载附件

shiruiqiang

baofa2 发表于 2024-4-5 07:39

老师的账号是换了吗？原来的fzxba老师吧？代码写法很眼熟，还在学习中