多文件夹下含*Con命名Excel文件的数据合并VBA宏需求

核心需求适配 #

针对合并多文件夹下文件名含*Con、单工作表（名称不固定）的Excel数据场景，以下是优化后的VBA代码，支持批量遍历嵌套文件夹、高效处理百万级数据：

Option Explicit

Sub ConsolidateMultiFolderData()
    Dim destWs As Worksheet
    Dim rootFolder As String
    Dim currentWb As Workbook
    Dim sourceWs As Worksheet
    Dim lastDestRow As Long, lastSourceRow As Long
    Dim sourceData As Variant
    Dim fso As Object, folder As Object, subFolder As Object, file As Object
    
    ' 设置目标工作表（当前工作簿的Sheet1）
    Set destWs = ThisWorkbook.Sheets("Sheet1")
    ' 获取根文件夹路径（弹窗选择）
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择要遍历的根文件夹"
        If .Show <> -1 Then Exit Sub
        rootFolder = .SelectedItems(1) & "\"
    End With
    
    ' 初始化文件系统对象
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 关闭屏幕刷新和警告，提升运行效率
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    
    ' 遍历根文件夹及所有子文件夹
    TraverseFolders fso.GetFolder(rootFolder), destWs
    
    ' 恢复Excel设置
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "数据合并完成！", vbInformation
End Sub

' 递归遍历文件夹的子过程
Sub TraverseFolders(currentFolder As Object, destWs As Worksheet)
    Dim file As Object
    Dim currentWb As Workbook
    Dim sourceWs As Worksheet
    Dim lastDestRow As Long, lastSourceRow As Long
    Dim sourceData As Variant
    
    ' 遍历当前文件夹下的文件
    For Each file In currentFolder.Files
        ' 筛选文件名包含"Con"的Excel文件（.xls/.xlsx/.xlsm）
        If (InStr(1, file.Name, "Con", vbTextCompare) > 0) And _
           (Right(file.Name, 4) = ".xls" Or Right(file.Name, 5) = ".xlsx" Or Right(file.Name, 5) = ".xlsm") Then
            
            ' 打开目标文件
            Set currentWb = Workbooks.Open(file.Path, ReadOnly:=True)
            ' 获取文件中唯一的工作表
            Set sourceWs = currentWb.Sheets(1)
            
            ' 获取源数据最后一行（从A列判断）
            lastSourceRow = sourceWs.Range("A" & sourceWs.Rows.Count).End(xlUp).Row
            ' 获取目标工作表最后一行（从A列判断）
            lastDestRow = destWs.Range("A" & destWs.Rows.Count).End(xlUp).Row + 1
            
            ' 仅当源数据有内容（至少表头+1行数据）时复制
            If lastSourceRow >= 2 Then
                ' 用数组读取源数据，提升百万行数据处理效率
                sourceData = sourceWs.Range("A2:Q" & lastSourceRow).Value
                ' 将数组写入目标工作表，避免剪贴板操作
                destWs.Range("A" & lastDestRow).Resize(UBound(sourceData, 1), UBound(sourceData, 2)).Value = sourceData
            End If
            
            ' 关闭文件，不保存更改
            currentWb.Close SaveChanges:=False
        End If
    Next file
    
    ' 递归遍历子文件夹
    For Each subFolder In currentFolder.SubFolders
        TraverseFolders subFolder, destWs
    Next subFolder
End Sub

关键修改说明 #

• 多文件夹遍历：通过Scripting.FileSystemObject递归遍历根文件夹下所有子文件夹，无需手动选择单个文件
• 文件名筛选：用InStr判断文件名是否包含"Con"，同时过滤Excel格式文件
• 工作表适配：直接取文件的第一个工作表Sheets(1)，解决工作表名称不固定的问题
• 效率优化：用数组读取和写入数据，替代剪贴板复制粘贴，大幅提升百万行数据的处理速度
• 只读打开：以只读模式打开源文件，避免文件锁定问题
• 状态恢复：关闭操作后恢复Excel的屏幕刷新、计算模式等默认设置

内容的提问来源于stack exchange，提问作者Chandrakumar Sundaram