多文件夹多工作簿同一sheet复制到新的表格

Lisianthus1

大神们  求一个代码

一个文件夹内有多个文件夹，同时多个文件夹里面还有多个工作簿（都不是同名的）
但是汇总的表格里面有一个sheet的名字是一样的
想把所有表格里面这个sheet复制到一个新的工作薄里面
不需要合并，直接复制到新工作簿的多个新sheet里面（sheet名为源文件名字）
请问可以写出这样的代码吗？
感谢 已上附件
想要的效果如下图

Lisianthus1

所有文件夹里面 只有“汇总一”“汇总二”“汇总三”里面有名为“汇总”的sheet噢

limonet

Dim Cn As Object
Sub limonet()
    Path$ = ThisWorkbook.Path
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 XML;Data Source=" & Path & "\limonet.xlsx"
    Call Recurse(Path)
    Set Cn = Nothing
End Sub
Function Recurse(Path) As String
    Dim F As Object, Folder As Object, SubF As Object
    Set Folder = CreateObject("scripting.filesystemobject").getfolder(Path)
    For Each F In Folder.Files
        If F.Name Like "汇总*" Then
            StrSQL = "Select * Into " & Split(F.Name, ".xls")(0) & " From [Excel 12.0;Database=" & F.Path & "].[汇总$]"
            Cn.Execute (StrSQL)
        End If
    Next F
    For Each SubF In Folder.subfolders
        Recurse (SubF.Path)
    Next SubF
End Function

limonet

关键字：recurse

超级拉风的小小

Sub tt()
    Dim folderpath As String
        ' 使用FileDialog选择文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "请选择一个文件夹"
        .AllowMultiSelect = False
        If .Show = -1 Then
            folderpath = .SelectedItems(1)
        Else
            MsgBox "未选择文件夹", vbExclamation
            Exit Sub
        End If
    End With
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    FindAllFiles folderpath
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
   
End Sub

Sub FindAllFiles(fsPath As String) '采用递归穿透子文件夹
    Dim fso As Object, file, folder, ws As Workbook
    Set fso = CreateObject("scripting.filesystemobject").getfolder(fsPath)
    For Each file In fso.Files
        If file.Name Like "汇总*.xls*" Then
            Set ws = Workbooks.Open(file.Path)
                ws.Sheets("汇总").Copy after:=ThisWorkbook.Sheets("sheet1")
                ws.Close
                Sheets("汇总").Name = Split(file.Name, ".")(0)
        End If
    Next
    For Each folder In fso.subfolders '这就是递归
        FindAllFiles fsPath & "\" & folder.Name
    Next
End Sub

超级拉风的小小

貌似这个更好点儿，不会有空白sheet，会在程序文件同目录里生成一个新工作簿，看看这个如何？
Dim a, wb As Workbook
Sub tt()
    Dim folderpath As String
        ' 使用FileDialog选择文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "请选择一个文件夹"
        .AllowMultiSelect = False
        If .Show = -1 Then
            folderpath = .SelectedItems(1)
        Else
            MsgBox "未选择文件夹", vbExclamation
            Exit Sub
        End If
    End With
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    FindAllFiles folderpath
    wb.SaveAs ThisWorkbook.Path & "\" & "汇总工作簿.xlsx": wb.Close
    Application.DisplayAlerts = True: Application.ScreenUpdating = True
    Set fso = Nothing: Set wb = Nothing
End Sub

Sub FindAllFiles(fsPath As String) '采用递归穿透子文件夹
    Dim fso As Object, file, folder, ws As Workbook
    Set fso = CreateObject("scripting.filesystemobject").getfolder(fsPath)
    For Each file In fso.Files
        If file.Name Like "汇总*.xls*" Then '根据自己需要去更改
            Set ws = Workbooks.Open(file.Path)
            If a = 0 Then
                ws.Sheets("汇总").Copy: Set wb = ActiveWorkbook
            Else
                ws.Sheets("汇总").Copy before:=wb.Sheets(1)
            End If
            ws.Close
            wb.Sheets(1).Name = Split(file.Name, ".")(0)
            a = a + 1
        End If
    Next
    For Each folder In fso.subfolders '这就是递归
        FindAllFiles fsPath & "\" & folder.Name
    Next
End Sub

ykcbf1100

参与一下。。。

ykcbf1100

fso法。。。

Lisianthus1

ykcbf1100 发表于 2024-10-31 13:31
参与一下。。。

老师 加了一个文件夹 但是结果还是只有原来的文件夹数据 因为是测试文件所以做的比较简单 但后续还会增加文件夹和工作薄的  共性是所有子文件夹里面都有一个不同名的工作薄，但是里面要提取的sheet名是一样的

ykcbf1100

Lisianthus1 发表于 2024-10-31 15:16
老师 加了一个文件夹 但是结果还是只有原来的文件夹数据 因为是测试文件所以做的比较简单 但后续还会增加 ...

你把附件做认真一点，不然，代码老得改来改去的。