Worksheet_Change仅触发一次及VBA数字格式不显示问题求助

问题概述 #

1. 事件仅触发一次：Worksheet_Change事件基于调整系数修改数据，但仅执行一次后失效，偶尔能多次触发但概率极低
2. 数字格式异常：编辑栏显示正确数字格式，但单元格未显示会计格式

核心问题分析 #

事件失效原因 #

• 错误处理不当：代码中滥用On Error Resume Next，会掩盖运行时错误，导致Application.EnableEvents = True可能无法执行，事件被永久禁用
• 变量未重置：startRng、EndRng等变量在循环后未清空，后续触发事件时会保留旧值，导致逻辑判断错误
• 冗余循环：不必要的Do While counter <= 2循环会重复执行逻辑，增加出错概率
• 未明确工作表引用：Cells、Range未指定工作表对象，默认使用ActiveSheet，可能导致引用错误

数字格式问题原因 #

• 仅给总计单元格（V29、V58）设置了会计格式，数据区域（F4:U28、F33:U57）未设置对应格式
• 格式字符串中的转义字符可能存在冲突，或设置格式后被单元格原有格式覆盖

修复后的代码 #

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet
    Set ws = Me '明确当前工作表，避免ActiveSheet引用错误
    
    '初始化环境设置，增加错误捕获确保恢复
    On Error GoTo Cleanup
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Dim modifier As Range, i As Integer, j As Integer
    Dim SheetAddress As Worksheet, SheetName As String
    Dim SheetRange As Range, cell As Range
    Dim startRng As Variant, EndRng As Variant, t As Long
    Dim rowcount As Long
    
    '_____________________________________|PART 1 - In $ AMOUNT|________________________________________________
    Set modifier = ws.Range("E4:U29")
    If Not Intersect(Target, modifier) Is Nothing Then
        For i = 4 To 28
            For j = 6 To 21
                '重置变量，避免旧值干扰
                startRng = Empty
                EndRng = Empty
                
                '获取目标工作表，增加错误判断
                SheetName = CStr(ws.Cells(i, j).End(xlUp).Value)
                On Error Resume Next
                Set SheetAddress = ThisWorkbook.Sheets(SheetName)
                On Error GoTo Cleanup
                If SheetAddress Is Nothing Then GoTo NextJ '工作表不存在则跳过
                
                '获取有效行数
                rowcount = SheetAddress.Range(SheetAddress.Cells(4, 2), SheetAddress.Cells(4, 2).End(xlDown)).Rows.Count
                For t = 4 To rowcount
                    If SheetAddress.Cells(t, 2).Value >= 27 And SheetAddress.Cells(t, 2).Value <= 51 Then
                        If IsEmpty(startRng) Then
                            startRng = SheetAddress.Cells(t, 2).Address
                        End If
                    End If
                    If SheetAddress.Cells(t, 2).Value <= 51 Then
                        EndRng = SheetAddress.Cells(t, 2).Address
                    End If
                Next t
                
                '判断范围是否有效
                If Not IsEmpty(startRng) And Not IsEmpty(EndRng) Then
                    Set SheetRange = SheetAddress.Range(startRng, EndRng)
                    '更新当前单元格值
                    For Each cell In SheetRange
                        If cell.Value = ws.Cells(i, "A").Value Then
                            ws.Cells(i, j).Value = cell.Offset(0, 9).Value * ws.Cells(i, "E").Value
                            '设置会计格式
                            ws.Cells(i, j).NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
                            Exit For '找到匹配项后退出循环，提升效率
                        End If
                    Next cell
                End If
NextJ:
            Next j
        Next i
    End If

    'column totals
    For j = 6 To 21
        ws.Cells(29, j).Value = WorksheetFunction.Sum(ws.Range(ws.Cells(29, j).Offset(-25), ws.Cells(29, j).Offset(-1)))
        ws.Cells(29, j).NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
    Next j

    'grand total
    ws.Cells(29, "V").Value = WorksheetFunction.Sum(ws.Range("F29:U29"))
    With ws.Cells(29, "V")
        .Interior.Color = RGB(255, 255, 0)
        .NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
    End With


    '_____________________________________|PART 2 - In UNITS (Hours)|___________________________________________
    Set modifier = ws.Range("E33:U58")
    If Not Intersect(Target, modifier) Is Nothing Then
        For i = 33 To 57
            For j = 6 To 21
                '重置变量
                startRng = Empty
                EndRng = Empty
                
                SheetName = CStr(ws.Cells(i, j).End(xlUp).Value)
                On Error Resume Next
                Set SheetAddress = ThisWorkbook.Sheets(SheetName)
                On Error GoTo Cleanup
                If SheetAddress Is Nothing Then GoTo NextJ2
                
                rowcount = SheetAddress.Range(SheetAddress.Cells(4, 2), SheetAddress.Cells(4, 2).End(xlDown)).Rows.Count
                For t = 4 To rowcount
                    If SheetAddress.Cells(t, 2).Value >= 27 And SheetAddress.Cells(t, 2).Value <= 51 Then
                        If IsEmpty(startRng) Then
                            startRng = SheetAddress.Cells(t, 2).Address
                        End If
                    End If
                    If SheetAddress.Cells(t, 2).Value <= 51 Then
                        EndRng = SheetAddress.Cells(t, 2).Address
                    End If
                Next t
                
                If Not IsEmpty(startRng) And Not IsEmpty(EndRng) Then
                    Set SheetRange = SheetAddress.Range(startRng, EndRng)
                    For Each cell In SheetRange
                        If cell.Value = ws.Cells(i, "A").Value Then
                            ws.Cells(i, j).Value = cell.Offset(0, 8).Value * ws.Cells(i, "E").Value
                            ws.Cells(i, j).NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
                            Exit For
                        End If
                    Next cell
                End If
NextJ2:
            Next j
        Next i
    End If

    ws.Range(ws.Cells(1, 6), ws.Cells(1, 21)).EntireColumn.AutoFit

    'column Totals
    For j = 6 To 21
        ws.Cells(58, j).Value = WorksheetFunction.Sum(ws.Range(ws.Cells(58, j).Offset(-25), ws.Cells(58, j).Offset(-1)))
        ws.Cells(58, j).NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
    Next j

    'grand Total
    ws.Cells(58, "V").Value = WorksheetFunction.Sum(ws.Range("F58:U58"))
    With ws.Cells(58, "V")
        .Interior.Color = RGB(255, 255, 0)
        .NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
    End With

Cleanup:
    '强制恢复环境设置，无论是否出错
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    '如果有错误，提示错误信息
    If Err.Number <> 0 Then
        MsgBox "运行错误: " & Err.Description, vbCritical
        Err.Clear
    End If
End Sub

关键修改说明 #

1. 增加错误捕获与恢复：通过On Error GoTo Cleanup确保Application.EnableEvents等设置在出错时也能恢复，避免事件被永久禁用
2. 变量重置：在每次循环前重置startRng、EndRng，避免旧值干扰逻辑
3. 明确工作表引用：使用Me指代当前工作表，所有Cells、Range都指定工作表对象，避免ActiveSheet引用错误
4. 移除冗余循环：删除不必要的Do While循环，减少重复执行
5. 格式统一设置：给数据区域（F4:U28、F33:U57）和总计单元格都设置会计格式
6. 优化循环效率：找到匹配项后用Exit For退出循环，减少不必要的遍历

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