Excel多工作表宏执行卡顿显示未响应，求优化方案

核心问题分析 #

你的宏卡顿主要来自两个关键原因：

• 逐个单元格遍历的低效IO：For Each c In rng1.Cells 会频繁读写工作表单元格，这是VBA中性能最差的操作类型之一，数据量稍大就会拖慢执行速度。
• 未关闭Excel默认耗时行为：宏运行时Excel仍在自动刷新屏幕、执行计算，额外消耗系统资源。

优化步骤 #

1. 用内存数组替代单元格循环，批量处理数据

把目标区域的数据一次性读到内存数组中完成判断，再统一写回工作表，大幅减少单元格IO操作：

Sub Date_Yes1()
    Dim Sh As Worksheet
    Dim lastRow As Long
    Dim dataE As Variant, dataC As Variant
    Dim i As Long
    
    Set Sh = ActiveSheet
    lastRow = Sh.Cells(Sh.Rows.Count, "E").End(xlUp).Row
    ' 数据行小于6时直接退出，避免空区域错误
    If lastRow < 6 Then Exit Sub
    
    ' 一次性读取E、C列数据到内存数组
    dataE = Sh.Range("E6:E" & lastRow).Value2
    dataC = Sh.Range("C6:C" & lastRow).Value2
    
    ' 在内存数组中循环判断
    For i = LBound(dataE, 1) To UBound(dataE, 1)
        If dataE(i, 1) = "Yes" And (dataC(i, 1) = "" Or IsEmpty(dataC(i, 1))) Then
            dataC(i, 1) = Format(Date, "mm/dd/yyyy")
        End If
    Next i
    
    ' 把处理后的C列数据一次性写回工作表
    Sh.Range("C6:C" & lastRow).Value2 = dataC
End Sub

2. 关闭Excel耗时默认设置，减少资源占用

在宏执行前后临时关闭屏幕刷新、自动计算等功能，执行完成后恢复：
修改工作表中的Worksheet_SelectionChange事件：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range("E6:E60")) Is Nothing Then
        ' 关闭耗时设置
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        Application.EnableEvents = False
        
        Call Date_Yes1
        
        ' 恢复默认设置
        Application.EnableEvents = True
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If
End Sub

3. 统一代码到标准模块，避免重复冗余

5个工作表逻辑完全相同，没必要在每个工作表重复写代码。可以把事件逻辑移到ThisWorkbook模块统一处理：

' 粘贴到ThisWorkbook模块中
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    ' 指定需要生效的工作表名称，根据实际情况修改
    Select Case Sh.Name
        Case "Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5"
            If Not Intersect(Target, Sh.Range("E6:E60")) Is Nothing Then
                Application.ScreenUpdating = False
                Application.Calculation = xlCalculationManual
                Application.EnableEvents = False
                
                ' 直接传入工作表对象，避免依赖ActiveSheet
                Date_Yes1 Sh
                
                Application.EnableEvents = True
                Application.Calculation = xlCalculationAutomatic
                Application.ScreenUpdating = True
            End If
    End Select
End Sub

同时修改Date_Yes1，接收工作表参数，避免依赖ActiveSheet（更稳定）：

' 粘贴到标准模块（比如Module1）中
Sub Date_Yes1(Sh As Worksheet)
    Dim lastRow As Long
    Dim dataE As Variant, dataC As Variant
    Dim i As Long
    
    lastRow = Sh.Cells(Sh.Rows.Count, "E").End(xlUp).Row
    If lastRow < 6 Then Exit Sub
    
    dataE = Sh.Range("E6:E" & lastRow).Value2
    dataC = Sh.Range("C6:C" & lastRow).Value2
    
    For i = LBound(dataE, 1) To UBound(dataE, 1)
        If dataE(i, 1) = "Yes" And (dataC(i, 1) = "" Or IsEmpty(dataC(i, 1))) Then
            dataC(i, 1) = Format(Date, "mm/dd/yyyy")
        End If
    Next i
    
    Sh.Range("C6:C" & lastRow).Value2 = dataC
End Sub

额外注意点 #

• 修正错误语法：VBA中没有Blank关键字，原代码里的.Range("C" & c.Row).Value2 = Blank是错误写法，应该用""或IsEmpty()判断空值，这也是潜在的性能损耗点。
• 按需缩小遍历范围：如果SelectionChange只触发在单个单元格，可优化为仅处理选中行，无需遍历整个E列，进一步提升速度。

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