将【测试】这个文件夹下所有的文件内同文件名的全部汇总在这个汇总表内

hmc530

kuangben8 发表于 2019-10-15 09:34
啥意思？没明白？

就是根据文件夹内的表格增加或减少，汇总表内的各个表也随着变化！这样就不用再新增表格的时候，还要在汇总表新增一个表格。。。。

kuangben8

hmc530 发表于 2019-10-15 10:00
就是根据文件夹内的表格增加或减少，汇总表内的各个表也随着变化！这样就不用再新增表格的时候，还要 ...

哦，明白了。稍等。

xiangbaoan

Option Explicit
Sub test()
Dim Sht As Worksheet, Cnn As Object, Rst As Object, Dic As Object, Fso As Object, Sql$, fld, fil, s$, i%
Set Cnn = CreateObject("ADODB.Connection")
Set Rst = CreateObject("ADODB.Recordset")
Set Dic = CreateObject("Scripting.Dictionary")
Set Fso = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    For Each Sht In Worksheets
        If Sht.Name <> ActiveSheet.Name Then Sht.Delete
    Next
Application.DisplayAlerts = True
Cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
For Each fld In Fso.GetFolder(ThisWorkbook.Path).SubFolders
    For Each fil In fld.Files
        s = fil.Name
        If Left(s, 2) <> "~$" Then
            s = Split(s, ".xls")(0)
            Sql = "SELECT * FROM [" & fil & "].[Sheet1$A1:T] WHERE 物料 IS NOT NULL"
            Rst.Open Sql, Cnn, 1, 3
            If Not Dic.Exists(s) Then
                Sheets.Add after:=Sheets(Sheets.Count)
                With ActiveSheet
                    For i = 0 To Rst.Fields.Count - 1
                        .[a1].Offset(0, i) = Rst.Fields(i).Name
                    Next
                    .[a2].CopyFromRecordset Rst
                    .Name = s
                End With
                Dic(s) = ""
            Else
                With Sheets(s)
                    .Cells(.Rows.Count, 3).End(xlUp).Offset(1, -2).CopyFromRecordset Rst
                End With
            End If
            If Rst.State = 1 Then Rst.Close
        End If
    Next
Next
Sheets(1).Activate
Cnn.Close
Set Cnn = Nothing
Set Rst = Nothing
Set Dic = Nothing
Set Fso = Nothing
Application.ScreenUpdating = True
MsgBox "ok!", 64
End Sub

xiangbaoan

………………

kuangben8

1. Sub 汇总()
   
2.     Dim PathStr As String, Fil As String
   
3.     Dim Wbook As Workbook, Sht As Worksheet
   
4.     Dim dic As Object
   
5.     Dim dic02 As Object
   
6.     Dim m%, n%, k&
   
7.     Dim arr, crr, brr(1000)    '直接定义一个大数组装文件
   
8.     Set dic = CreateObject("Scripting.Dictionary")
   
9.     Set dic02 = CreateObject("Scripting.Dictionary")
   
10.     Application.ScreenUpdating = False
    
11.     With ThisWorkbook
    
12.         For m = 1 To .Worksheets.Count
    
13.             dic02(.Worksheets(m).Name) = ""      '将工作表名写入字典中，方便后续查找
    
14.         Next
    
15.     End With
    
16.     PathStr = ThisWorkbook.Path & ""
    
17.     dic(PathStr) = ""
    
18.     m = 0
    
19.     Do While m < dic.Count
    
20.         arr = dic.keys
    
21.         Fil = Dir(arr(m), vbDirectory)
    
22.         Do While Fil <> ""
    
23.             If Fil <> "." And Fil <> ".." And Fil <> ThisWorkbook.Name Then      '获取的代码工作簿名称不用统计。
    
24.                 If (GetAttr(arr(m) & Fil) And vbDirectory) = vbDirectory Then
    
25.                     dic(arr(m) & Fil & "") = ""
    
26.                 Else
    
27.                     n = n + 1
    
28.                     brr(n - 1) = Mid(Fil, 1, InStrRev(Fil, ".") - 1)    '提取去除文件扩展名的文件名称
    
29.                     If Not dic02.exists(brr(n - 1)) Then    '如果该工作簿名称不在字典dic02中，则先添加工作表，后对应汇总。
    
30.                         With ThisWorkbook
    
31.                             .Worksheets.Add after:=.Sheets(.Sheets.Count)     '添加一个新工作表并放在最后
    
32.                             .Sheets(.Sheets.Count - 1).Rows("1:1").Copy        '复制前一个工作表的第一行
    
33.                             With .Sheets(.Sheets.Count)
    
34.                                 .Name = brr(n - 1)                           '修改工作表名
    
35.                                 dic02(brr(n - 1)) = ""              '将新建的工作表名写入dic02中，防止后续重复创建！
    
36.                                 .Range("A1").PasteSpecial Paste:=xlPasteColumnWidths    '先选择性粘贴列宽
    
37.                                 .Paste                                                  '后粘贴内容
    
38.                             End With
    
39.                             Application.CutCopyMode = False      '清除蚂蚁线
    
40.                         End With
    
41.                     End If
    
42.                     Set Wbook = GetObject(arr(m) & Fil)     '后台打开对应的工作簿
    
43.                     Set Sht = Wbook.Worksheets(1)
    
44.                     With Sht                                 'Workbooks(Fil).Worksheets(1)对应工作簿打开好使，不打开直接引用不好使！    '提取对应工作簿的第一个工作表数据
    
45.                         crr = .Range("A1").CurrentRegion.Offset(1, 0)        '会多引用一行空行。
    
46.                     End With
    
47.                     Wbook.Close False    '提取数据之后必须关闭工作簿，防止下次打开同名工作簿出错！
    
48.                     With ThisWorkbook.Worksheets(brr(n - 1))
    
49.                         k = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row '获取目标工作表的第一个空行行号
    
50.                         .Range("A" & k).Resize(UBound(crr, 1), UBound(crr, 2)) = crr
    
51.                         .Cells(k, UBound(crr, 2) + 1).Resize(UBound(crr, 1) - 1, 1) = WorksheetFunction.Substitute(arr(m), PathStr, "") & Fil '将对应工作簿含路径的名称写入目标工作表
    
52.                     End With
    
53.                 End If
    
54.             End If
    
55.             Fil = Dir
    
56.         Loop
    
57.         m = m + 1
    
58.     Loop
    
59.     Application.ScreenUpdating = True
    
60.     MsgBox "提取文件夹中对应文件数据完毕！"
    
61. End Sub

复制代码

kuangben8

参考看看吧。
多文件夹多工作簿数据汇总.zip (422.56 KB, 下载次数: 15)

2019-10-15 15:11 上传

点击文件名下载附件

hmc530

kuangben8 发表于 2019-10-15 15:03
参考看看吧。

https://club.excelhome.net/thread-1629331-1-1.html
帮我看看这个问题咯！谢谢！