VBA合并子文件夹Excel文件时，处理第二个子文件夹Excel无提示崩溃

问题根源 #

• 嵌套Dir()函数冲突：Dir是全局状态函数，外层遍历子文件夹时使用Dir，内层遍历文件又调用Dir()，会覆盖外层的遍历上下文，导致外层循环在处理第二个子文件夹时无法正确获取下一个文件夹，触发Excel崩溃。
• xlCellTypeLastCell不可靠：当合并工作表为空时，SpecialCells(xlCellTypeLastCell)可能返回错误的行号，极端情况会引发未捕获的错误。
• 缺乏错误处理：未处理文件打开失败、Sheet1不存在等异常情况，一旦触发错误直接导致Excel崩溃。

修复后的代码 #

Sub MergeExcelFiles()
    Dim fso As Object
    Dim masterFolderObj As Object, subFolderObj As Object
    Dim fileObj As Object
    Dim mergeWB As Workbook, sourceWB As Workbook
    Dim mergeWS As Worksheet, sourceWS As Worksheet
    Dim nextRow As Long
    Dim masterPath As String
    
    masterPath = "C:\Users\Username\Desktop\2022\"
    
    ' 创建FileSystemObject，避免Dir函数的全局冲突
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set masterFolderObj = fso.GetFolder(masterPath)
    
    On Error GoTo ErrorHandler ' 添加错误捕获
    
    ' 遍历所有子文件夹
    For Each subFolderObj In masterFolderObj.SubFolders
        ' 创建新的合并工作簿（仅含一个工作表）
        Set mergeWB = Workbooks.Add(xlWBATWorksheet)
        Set mergeWS = mergeWB.Sheets(1)
        nextRow = 1 ' 初始化起始行
        
        ' 遍历子文件夹中的Excel文件
        For Each fileObj In subFolderObj.Files
            ' 只处理xlsx/xls格式文件
            If LCase(fso.GetExtensionName(fileObj.Path)) Like "xls*" Then
                Set sourceWB = Workbooks.Open(fileObj.Path, ReadOnly:=True)
                Set sourceWS = sourceWB.Sheets(1)
                
                ' 复制数据：第一个文件复制表头+数据，后续文件跳过表头只复制数据
                If nextRow = 1 Then
                    sourceWS.UsedRange.Copy mergeWS.Range("A" & nextRow)
                    nextRow = mergeWS.Cells(mergeWS.Rows.Count, "A").End(xlUp).Row + 1
                Else
                    sourceWS.UsedRange.Offset(1).Copy mergeWS.Range("A" & nextRow)
                    nextRow = mergeWS.Cells(mergeWS.Rows.Count, "A").End(xlUp).Row + 1
                End If
                
                sourceWB.Close SaveChanges:=False
            End If
        Next fileObj
        
        ' 保存合并文件
        mergeWB.SaveAs Filename:=subFolderObj.Path & "\" & subFolderObj.Name & "_Merged.xlsx", _
                       FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        mergeWB.Close SaveChanges:=False
    Next subFolderObj
    
    MsgBox "合并完成！"
    Exit Sub
    
ErrorHandler:
    MsgBox "处理过程中出错：" & Err.Description & vbCrLf & "涉及文件：" & IIf(Not fileObj Is Nothing, fileObj.Path, "未知路径")
    ' 清理异常状态下的工作簿
    If Not sourceWB Is Nothing Then sourceWB.Close SaveChanges:=False
    If Not mergeWB Is Nothing Then mergeWB.Close SaveChanges:=False
End Sub

关键修复说明 #

1. 替换Dir为FileSystemObject：通过Scripting.FileSystemObject遍历文件夹和文件，彻底避免了Dir函数的全局状态冲突，解决嵌套遍历导致的崩溃问题。
2. 稳定的行号计算：用mergeWS.Cells(mergeWS.Rows.Count, "A").End(xlUp).Row + 1获取下一个空行，比xlCellTypeLastCell更可靠，能正确处理空表场景。
3. 添加错误捕获机制：异常发生时会弹出错误提示，并自动清理打开的工作簿，避免Excel无提示崩溃。
4. 精准筛选Excel文件：通过扩展名判断仅处理xls/xlsx格式文件，避免无效文件干扰。
5. 可选去重表头：代码默认第一个文件复制表头，后续文件跳过表头，符合多数合并需求（不需要可删除该判断逻辑）。

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