合并多个.CSV文件至主工作簿时VBA宏异常中断问题求助

宏停止运行的核心原因 #

1. 文件夹选择逻辑完全错误：原代码用文件选择对话框（msoFileDialogFilePicker）却试图获取文件夹路径，选完文件后返回的是文件名而非文件夹，后续读取文件夹时直接触发错误，但错误被静默捕获，导致宏无提示停止。
2. CSV工作表名硬编码错误：CSV打开后默认工作表名是文件名（不带.csv），不是固定的Sheet1，引用Sheet1会触发错误。
3. 工作簿引用不稳定：用Application.Workbooks(1)指代主工作簿，打开新CSV后工作簿顺序会变，导致引用错位。
4. 错误处理无反馈：出错后直接跳转到收尾流程，没有任何错误提示，根本不知道哪里出问题。

模板代码转移失效的原因 #

原代码依赖ActiveWorkbook、Workbooks(1)这类动态引用，转移到新工作簿后，这些引用的指向会混乱；没有用ThisWorkbook明确指定运行宏的工作簿，导致上下文出错。

修复后的完整代码 #

Option Explicit

Private Sub CommandButton1_Click()
    mergeData
End Sub

Sub mergeData()
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Dim objFs As Object
    Dim objFolder As Object
    Dim file As Object
    
    Dim sPath As String
    sPath = chooseFolder()
    If sPath = "" Then Exit Sub
    
    Set objFs = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFs.GetFolder(sPath)
    
    ' 明确指定运行宏的主工作簿
    Dim wbMaster As Workbook
    Set wbMaster = ThisWorkbook
    ' 合并到第一个工作表，要每个文件一个表可改这里
    Dim wsMaster As Worksheet
    Set wsMaster = wbMaster.Worksheets(1)
    Dim lastRowMaster As Long
    
    For Each file In objFolder.Files
        ' 只处理CSV文件
        If LCase(objFs.GetExtensionName(file.Path)) = "csv" Then
            Dim objSrc As Workbook
            Set objSrc = Workbooks.Open(file.Path, True, True)
            
            Dim wsSrc As Worksheet
            Set wsSrc = objSrc.Worksheets(1) ' CSV只有一个表，用索引更靠谱
            
            Dim rngSrc As Range
            Set rngSrc = wsSrc.UsedRange
            ' 第一个文件保留表头，后续跳过表头
            If wsMaster.Cells(1, 1) = "" Then
                Set rngSrc = rngSrc
            Else
                Set rngSrc = rngSrc.Offset(1).Resize(rngSrc.Rows.Count - 1)
            End If
            
            ' 找主表最后一行，追加数据
            lastRowMaster = wsMaster.Cells(wsMaster.Rows.Count, 1).End(xlUp).Row + 1
            ' 批量复制，比循环快N倍
            rngSrc.Copy wsMaster.Cells(lastRowMaster, 1)
            
            objSrc.Close False
            Set objSrc = Nothing
        End If
    Next
    
ExitSub:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Exit Sub
    
ErrHandler:
    MsgBox "出错了：" & Err.Description & vbCrLf & "错误码：" & Err.Number, vbCritical
    Resume ExitSub
End Sub

' 正确的文件夹选择对话框
Function chooseFolder() As String
    Dim fd As Office.FileDialog
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    
    With fd
        .Title = "选一下放CSV的文件夹"
        .AllowMultiSelect = False
        
        If .Show = True Then
            chooseFolder = .SelectedItems(1)
        Else
            chooseFolder = ""
        End If
    End With
End Function

可选：每个CSV单独一个工作表 #

如果不需要合并到同一个表，而是每个CSV对应一个工作表，把mergeData里的合并逻辑换成下面这段：

' 替换原合并逻辑
Dim wsNew As Worksheet
' 新建工作表
Set wsNew = wbMaster.Sheets.Add(After:=wbMaster.Sheets(wbMaster.Sheets.Count))
' 去掉.csv后缀作为表名
wsNew.Name = Left(file.Name, Len(file.Name) - 4)
' 复制数据
wsSrc.UsedRange.Copy wsNew.Cells(1, 1)

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