遍历文件夹及子文件夹提取所有数据

Sub ExtractDataFromFoldersRecursively()
    Dim SourceFolder As String
    Dim DestWorkbook As Workbook
    Dim DestWorksheet As Worksheet
    Dim Conn As Object
    Dim rs As Object
    Dim strSQL As String
    Dim SourceFiles() As String
    Dim i As Integer
    ' 设置源文件夹的路径
    SourceFolder = "C:\\YourParentFolderPath\\"
    ' 创建一个新的工作簿
    Set DestWorkbook = Workbooks.Add
    Set DestWorksheet = DestWorkbook.Sheets(1)
    ' 创建ADO连接对象
    Set Conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    ' 打开连接到Excel工作簿的数据源
    Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & SourceFolder & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"
    ' 获取所有 Excel 文件的路径
    GetExcelFiles SourceFolder, SourceFiles
    ' 一次性执行 SQL 查询
    strSQL = "SELECT * FROM ["
    For i = 1 To UBound(SourceFiles)
        strSQL = strSQL & "[" & SourceFiles(i) & "$]"
        If i < UBound(SourceFiles) Then strSQL = strSQL & " UNION ALL SELECT * FROM "
    Next i
    strSQL = strSQL & ";"
    rs.Open strSQL, Conn
    ' 将查询结果复制到目标工作表
    DestWorksheet.Cells(1, 1).CopyFromRecordset rs
    rs.Close
    Conn.Close
    ' 保存新工作簿
    DestWorkbook.SaveAs "C:\\YourOutputPath\\OutputWorkbook.xlsx"
    DestWorkbook.Close SaveChanges:=False
    MsgBox "数据提取完成!"
End Sub

Sub GetExcelFiles(ByVal FolderPath As String, ByRef Files() As String)
    Dim FSO As Object
    Dim FileItem As Object
    Dim i As Integer
    Set FSO = CreateObject("Scripting.FileSystemObject")
    ' 遍历当前文件夹中的文件
    For Each FileItem In FSO.GetFolder(FolderPath).Files
        If InStr(1, FileItem.Name, ".xls", vbTextCompare) > 0 Then
            ReDim Preserve Files(i)
            Files(i) = FileItem.Name
            i = i + 1
        End If
    Next FileItem
    ' 递归处理子文件夹
    For Each SubFolder In FSO.GetFolder(FolderPath).Subfolders
        GetExcelFiles SubFolder.Path, Files
    Next SubFolder
End Sub