VBA遍历文件夹文件时Excel卡顿冻结，需完善合并数据及文件移动功能

卡顿问题的优化方向 #

原代码仅关闭了屏幕刷新，但Excel后台还有不少默认操作会拖慢执行速度，彻底优化需加上这些设置：

• 禁用事件触发（Application.EnableEvents = False），避免打开文件时触发不必要的宏或内置事件
• 将计算模式切换为手动（Application.Calculation = xlCalculationManual），防止每次打开文件自动重算
• 打开工作簿时指定只读模式、禁用链接更新，减少加载时的资源消耗

完整功能实现代码 #

以下是整合数据合并、文件移动功能的优化代码，同时解决卡顿问题：

Sub MergeFilesAndMove()
    Dim FolderPath As String, TargetFolder As String
    Dim CName As String
    Dim DiaFolder As FileDialog
    Dim mwb As Workbook
    Dim TargetWS As Worksheet
    Dim LastRow As Long, SourceLastRow As Long, SourceLastCol As Long
    
    ' 初始化目标工作表（默认用当前工作簿的第一个工作表，可按需修改）
    Set TargetWS = ThisWorkbook.Sheets(1)
    TargetWS.Cells.Clear ' 清空原有数据，如需保留可删除该行
    
    ' 关闭Excel后台耗资源的设置
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    ' 选择源文件夹
    Set DiaFolder = Application.FileDialog(msoFileDialogFolderPicker)
    With DiaFolder
        .AllowMultiSelect = False
        If .Show <> -1 Then GoTo Cleanup ' 用户取消选择则退出
        FolderPath = .SelectedItems(1)
    End With
    
    ' 创建目标文件夹（在源文件夹下生成"已处理文件"目录）
    TargetFolder = FolderPath & "\已处理文件"
    If Dir(TargetFolder, vbDirectory) = "" Then MkDir TargetFolder
    
    ' 遍历文件夹中的xlsx文件
    CName = Dir(FolderPath & "\*.xlsx")
    Do While CName <> ""
        ' 跳过当前工作簿本身，避免循环处理自己
        If CName <> ThisWorkbook.Name Then
            On Error Resume Next ' 捕获文件被占用等异常
            ' 以只读、禁用链接更新的方式打开文件，减少卡顿
            Set mwb = Workbooks.Open(FolderPath & "\" & CName, _
                                    ReadOnly:=True, _
                                    UpdateLinks:=xlUpdateLinksNever)
            If Err.Number = 0 Then ' 文件打开成功
                ' 复制第一个工作表的所有数据（可修改Sheets(1)指定其他工作表）
                With mwb.Sheets(1)
                    SourceLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                    SourceLastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
                    ' 找到目标工作表的最后一行，避免覆盖已有数据
                    LastRow = TargetWS.Cells(TargetWS.Rows.Count, 1).End(xlUp).Row + 1
                    ' 如需跳过表头，把Cells(1,1)改成Cells(2,1)
                    .Range(.Cells(1, 1), .Cells(SourceLastRow, SourceLastCol)).Copy _
                        TargetWS.Cells(LastRow, 1)
                End With
                mwb.Close SaveChanges:=False ' 只读打开无需保存
                ' 移动文件到目标文件夹
                Name FolderPath & "\" & CName As TargetFolder & "\" & CName
            Else
                ' 输出错误信息到调试窗口，方便排查问题
                Debug.Print "无法处理文件：" & CName & "，错误：" & Err.Description
            End If
            On Error GoTo 0 ' 恢复默认错误处理
        End If
        CName = Dir ' 取下一个文件
    Loop
    
Cleanup:
    ' 恢复Excel默认设置，避免影响后续操作
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox "处理完成！"
End Sub

关键代码说明 #

• 卡顿优化：通过关闭事件、手动计算、只读打开等方式，大幅降低Excel的资源占用，避免冻结
• 数据合并：默认将每个文件的第一个工作表数据追加到当前工作簿的第一个工作表，可根据需求修改工作表索引或名称
• 文件移动：自动创建"已处理文件"目录，处理完成的文件会被移动至此，避免重复处理
• 错误处理：捕获文件被占用等异常，防止代码崩溃，同时记录错误信息方便排查

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