改进VBA代码：批量合并多Excel的DATA工作表并记录源文件名

原代码存在的问题 #

• 过度依赖Activate和Select操作，代码稳定性差，易因窗口状态变化报错
• 未指定仅处理名为DATA的工作表，遍历所有表的逻辑混乱
• 固定复制A2:U200范围，无法适配数据行数的动态变化
• 缺少合并文件名的记录功能，无法追溯处理情况
• 无错误处理机制，遇到文件打不开、无目标表等异常时会直接崩溃

优化后的代码 #

Sub MergeDATAWorksheets()
    Dim MyFolder As String, MyFile As String
    Dim wbMain As Workbook, wbSource As Workbook
    Dim wsMainData As Worksheet, wsLog As Worksheet
    Dim lastRowMain As Long, lastRowSource As Long
    Dim fileCount As Integer
    
    ' 关闭不必要的Excel功能提升运行效率
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    ' 获取待合并文件所在文件夹路径
    MyFolder = InputBox("输入待合并文件所在文件夹路径")
    If Right(MyFolder, 1) <> "\" Then MyFolder = MyFolder & "\"
    
    ' 自动创建合并用的主工作簿
    Set wbMain = Workbooks.Add
    ' 创建数据合并工作表和合并日志工作表
    Set wsMainData = wbMain.Sheets(1)
    wsMainData.Name = "合并数据"
    Set wsLog = wbMain.Sheets.Add(After:=wsMainData)
    wsLog.Name = "合并日志"
    ' 写入日志表头
    wsLog.Range("A1").Value = "序号"
    wsLog.Range("B1").Value = "已合并文件名"
    fileCount = 0
    
    ' 遍历文件夹中的Excel文件（仅处理xlsx格式，如需其他格式可修改后缀）
    MyFile = Dir(MyFolder & "*.xlsx")
    Do While MyFile <> ""
        fileCount = fileCount + 1
        On Error Resume Next ' 捕获文件打开异常
        Set wbSource = Workbooks.Open(MyFolder & MyFile)
        
        ' 处理文件打开失败的情况
        If Err.Number <> 0 Then
            wsLog.Cells(fileCount + 1, 1).Value = fileCount
            wsLog.Cells(fileCount + 1, 2).Value = MyFile & " [打开失败]"
            Err.Clear
            MyFile = Dir
            GoTo NextFile
        End If
        
        ' 定位源文件中的DATA工作表
        Dim wsSourceData As Worksheet
        Set wsSourceData = Nothing
        On Error Resume Next
        Set wsSourceData = wbSource.Worksheets("DATA")
        On Error GoTo 0
        
        If Not wsSourceData Is Nothing Then
            ' 第一次复制时同时复制表头
            If lastRowMain = 0 Then
                wsSourceData.UsedRange.Copy wsMainData.Range("A1")
                lastRowMain = wsMainData.UsedRange.Rows.Count
            Else
                ' 动态获取源数据最后一行，仅复制有效数据（跳过表头）
                lastRowSource = wsSourceData.Cells(wsSourceData.Rows.Count, "A").End(xlUp).Row
                If lastRowSource >= 2 Then
                    wsSourceData.Range("A2:U" & lastRowSource).Copy _
                        wsMainData.Range("A" & lastRowMain + 1)
                    lastRowMain = wsMainData.Cells(wsMainData.Rows.Count, "A").End(xlUp).Row
                End If
            End If
            ' 记录成功合并的文件
            wsLog.Cells(fileCount + 1, 1).Value = fileCount
            wsLog.Cells(fileCount + 1, 2).Value = MyFile
        Else
            ' 记录无DATA工作表的文件
            wsLog.Cells(fileCount + 1, 1).Value = fileCount
            wsLog.Cells(fileCount + 1, 2).Value = MyFile & " [无DATA工作表]"
        End If
        
        ' 关闭源文件，不保存修改
        wbSource.Close SaveChanges:=False
NextFile:
        MyFile = Dir
    Loop
    
    ' 自动调整日志表列宽
    wsLog.Columns("A:B").AutoFit
    
    ' 恢复Excel默认功能
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
    MsgBox "合并完成！共处理" & fileCount & "个文件", vbInformation
End Sub

代码核心优化点 #

• 摒弃Activate/Select操作，直接通过对象引用操作工作表和单元格，大幅提升代码稳定性
• 精准定位名为DATA的工作表，避免无效遍历
• 动态获取数据范围，根据实际数据行数复制，适配不同文件的数据量
• 新增合并日志功能，记录所有文件的处理状态（成功、失败、无目标表）
• 增加错误处理，捕获文件打开异常，避免程序崩溃
• 自动创建主工作簿，无需提前手动新建合并文件

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