Worksheet_Change事件处理大单元格区域时Excel无响应的问题排查求助

看起来你的问题大概率是事件循环触发加上无边界的Do While循环导致的Excel卡死，咱们一步步来分析和解决：

核心问题点排查 #

• 缺少事件禁用机制：代码修改ws工作表单元格时，会再次触发Worksheet_Change事件（哪怕目标工作表没有这个事件，当前表的操作也可能间接触发），形成无限循环直接导致假死。
• Do While循环无边界：Do While BMS = ""会一直往上查找BMS值，如果目标单元格上方的B列一直是空值，这个循环会无限执行，瞬间占满CPU让Excel未响应。
• 大区域遍历+复制粘贴：监控范围D13:AU91不算特别大，但如果一次修改多个单元格（比如批量粘贴），逐个处理+整行复制粘贴的操作会大幅增加耗时。

优化后的代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 先禁用事件、屏幕更新和自动计算，避免循环和卡顿
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim rng As Range, cell As Range
    Set rng = Intersect(Target, Me.Range("D13:AU91"))
    
    ' 如果修改区域不在监控范围内，直接退出
    If rng Is Nothing Then GoTo Cleanup

    Dim ws As Worksheet, wb As Worksheet
    Set ws = ThisWorkbook.Worksheets("Desviaciones UB")
    Set wb = ThisWorkbook.Worksheets("UB-Clase A")

    For Each cell In rng
        If cell.Value = "N.I.O" Then
            Dim lastRow As Long, NumFila As Long
            lastRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
            NumFila = cell.Row

            ' 复制行格式（也可以直接设置格式，比复制粘贴更快）
            ws.Rows(lastRow).Copy
            ws.Rows(lastRow + 1).PasteSpecial Paste:=xlPasteFormats
            Application.CutCopyMode = False

            ' 用With语句简化单元格赋值，提升效率和可读性
            With ws.Cells(lastRow + 1, 2)
                .Value = lastRow - 3
                .Offset(0, 1).Value = "TPM"
                .Offset(0, 2).Value = "KW" & NumSemana ' 注意：NumSemana需要提前定义赋值
                .Offset(0, 4).Value = wb.Cells(NumFila, 3)
                .Offset(0, 12).Value = "Portavoz"
            End With

            ' 查找BMS值，添加边界判断防止无限循环
            Dim i As Long, BMS As String
            BMS = ""
            i = 1
            ' 限制查找范围不超过第1行，避免单元格越界
            Do While BMS = "" And (NumFila - i) >= 1
                BMS = Me.Cells(NumFila - i, 2).Value ' 明确指定当前工作表，避免引用错误
                i = i + 1
            Loop
            ' 找到则赋值，没找到给出提示
            If BMS <> "" Then
                ws.Cells(lastRow + 1, 5).Value = BMS
            Else
                MsgBox "单元格" & cell.Address & "上方未找到BMS值！", vbExclamation
            End If
        End If
    Next

Cleanup:
    ' 不管代码是否出错，都要恢复Excel默认设置
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

关键改动说明 #

1. 新增Application.EnableEvents = False彻底避免事件循环，用GoTo Cleanup确保即使代码出错也能恢复事件设置。
2. 给Do While循环加上(NumFila - i) >= 1的边界，防止无限循环和单元格越界。
3. 用With语句简化赋值逻辑，提升执行效率和代码可读性。
4. 明确指定Me.Cells查找BMS值，避免因活动工作表变化导致的引用错误。
5. 添加未找到BMS值的提示，方便排查问题。

另外提醒：代码里的NumSemana变量没有定义和赋值，记得补充这部分逻辑，否则会报错哦！

备注：内容来源于stack exchange，提问作者Edu1243