VBA Worksheet_Change事件内存溢出崩溃问题求助

问题描述 #

编写的Worksheet_Change事件代码运行时触发内存溢出崩溃，经排查问题出在For Each Cell In SheetRange循环段，监视列表显示异常。尝试设置Application.EnableEvents、移除counter循环，均无法解决崩溃问题。

原代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim modifier As Range, i As Integer, j As Integer, R As Variant
Dim counter As Integer, SheetAddress As Worksheet, SheetName As String, SheetRange As Range, cell As Range
Dim startRng As Variant, EndRng As Variant, Brng As Range, t As Variant
'_____________________________________|PART 1 - In $ AMOUNT|________________________________________________
Set modifier = Range("E4:U29")

If Not Intersect(Target, modifier) Is Nothing Then
    counter = 1
    Do While counter <= 2
        For i = 4 To 28
            For j = 6 To 21
                'On Error Resume Next
                Dim rowcount As Variant
                SheetName = CStr(Cells(i, j).End(xlUp))
                Set SheetAddress = Sheets(SheetName)
                rowcount = SheetAddress.Range(SheetAddress.Cells(6, 2), SheetAddress.Cells(6, 2).End(xlDown)).Rows.Count
                For t = 4 To rowcount
                    If SheetAddress.Cells(t, 2) >= 27 And SheetAddress.Cells(t, 2) <= 51 Then
                        If IsEmpty(startRng) Then
                            startRng = SheetAddress.Cells(t, 2).Address
                        End If
                    End If
                    If SheetAddress.Cells(t, 2) <= 51 Then
                        EndRng = SheetAddress.Cells(t, 2).Address
                    End If
                Next t
                        
                Set SheetRange = SheetAddress.Range(startRng, EndRng)
                Dim offsetstart As Variant, offsetend As Variant
                offsetstart = SheetAddress.Range(startRng).Offset(0, 9)
                offsetend = SheetAddress.Range(EndRng).Offset(0, 9)
                
                'formula
                For Each cell In SheetRange
                    If cell.Value = Cells(i, "A") Then
                        Cells(i, j) = cell.Offset(0, 9) * Cells(i, "E")
                    End If
                Next cell
            Next j
        Next i
        counter = counter + 1
    Loop
End If

'column totals
For j = 6 To 21
    Cells(29, j) = WorksheetFunction.Sum(Range(Cells(29, j).Offset(-25), Cells(29, j).Offset(-1)))
Next j

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


'_____________________________________|PART 2 - In UNITS (Hours)|___________________________________________
Dim startcell As Integer, endcell As Integer, Brange As Range
Set modifier = Range("E33:U58")

If Not Intersect(Target, modifier) Is Nothing Then
    counter = 1
    Do While counter <= 2
        For i = 33 To 57
            For j = 6 To 21
                On Error Resume Next
                SheetName = CStr(Cells(i, j).End(xlUp))
                Set SheetAddress = Sheets(SheetName)
                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) >= 27 And SheetAddress.Cells(t, 2) <= 51 Then
                        If IsEmpty(startRng) Then
                            startRng = SheetAddress.Cells(t, 2).Address
                        End If
                    End If
                    If SheetAddress.Cells(t, 2) <= 51 Then
                        EndRng = SheetAddress.Cells(t, 2).Address
                    End If
                Next t
                        
                Set SheetRange = SheetAddress.Range(startRng, EndRng)
                offsetstart = SheetAddress.Range(startRng).Offset(0, 9)
                offsetend = SheetAddress.Range(EndRng).Offset(0, 9)
                'formula
                For Each cell In SheetRange
                    If cell.Value = Cells(i, "A") Then
                        Cells(i, j) = cell.Offset(0, 8) * Cells(i, "E")
                    End If
                Next cell
            Next j
        Next i
    counter = counter + 1
    Loop
End If

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

'column Totals
For j = 6 To 21
    Cells(58, j) = WorksheetFunction.Sum(Range(Cells(58, j).Offset(-25), Cells(58, j).Offset(-1)))
Next j

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



Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

问题根源及修复方案 #

核心问题 #

• startRng和EndRng未重置：这两个变量在循环中未每次初始化，导致每次迭代累积之前的地址，最终SheetRange被设置成异常庞大的区域，遍历触发内存溢出。
• 嵌套层级过多+重复执行：原代码有多层嵌套循环，还包含不必要的Do While counter <=2重复执行，大幅增加计算量。
• 未禁用事件触发：修改单元格值时会再次触发Worksheet_Change事件，形成递归调用，加剧内存占用。

修复后的代码 #

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

    Dim modifier As Range, i As Integer, j As Integer
    Dim SheetAddress As Worksheet, SheetName As String, SheetRange As Range
    Dim startRng As Variant, EndRng As Variant, rowcount As Long, t As Long
    Dim targetVal As Variant, multiplier As Double

    ' -------------------------- 处理金额区域（E4:U29） --------------------------
    Set modifier = Me.Range("E4:U29")
    If Not Intersect(Target, modifier) Is Nothing Then
        For i = 4 To 28
            multiplier = Me.Cells(i, "E").Value
            targetVal = Me.Cells(i, "A").Value
            For j = 6 To 21
                ' 重置起始/结束区域变量
                startRng = Empty
                EndRng = Empty
                
                SheetName = CStr(Me.Cells(i, j).End(xlUp).Value)
                Set SheetAddress = ThisWorkbook.Sheets(SheetName)
                
                ' 获取有效行数，避免空行干扰
                rowcount = SheetAddress.Cells(SheetAddress.Rows.Count, 2).End(xlUp).Row
                ' 遍历目标列，确定范围
                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
                        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 = targetVal Then
                            Me.Cells(i, j).Value = cell.Offset(0, 9).Value * multiplier
                            Exit For ' 找到匹配项后直接退出循环，减少遍历
                        End If
                    Next cell
                End If
            Next j
        Next i
    End If

    ' 计算金额区域总计
    For j = 6 To 21
        Me.Cells(29, j).Value = WorksheetFunction.Sum(Me.Range(Me.Cells(4, j), Me.Cells(28, j)))
    Next j
    With Me.Cells(29, "V")
        .Value = WorksheetFunction.Sum(Me.Range("F29:U29"))
        .Interior.Color = RGB(255, 255, 0)
        .NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
    End With

    ' -------------------------- 处理工时区域（E33:U58） --------------------------
    Set modifier = Me.Range("E33:U58")
    If Not Intersect(Target, modifier) Is Nothing Then
        For i = 33 To 57
            multiplier = Me.Cells(i, "E").Value
            targetVal = Me.Cells(i, "A").Value
            For j = 6 To 21
                ' 重置起始/结束区域变量
                startRng = Empty
                EndRng = Empty
                
                SheetName = CStr(Me.Cells(i, j).End(xlUp).Value)
                Set SheetAddress = ThisWorkbook.Sheets(SheetName)
                
                rowcount = SheetAddress.Cells(SheetAddress.Rows.Count, 2).End(xlUp).Row
                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
                        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 = targetVal Then
                            Me.Cells(i, j).Value = cell.Offset(0, 8).Value * multiplier
                            Exit For ' 找到匹配项后退出循环
                        End If
                    Next cell
                End If
            Next j
        Next i
    End If

    ' 计算工时区域总计
    For j = 6 To 21
        Me.Cells(58, j).Value = WorksheetFunction.Sum(Me.Range(Me.Cells(33, j), Me.Cells(57, j)))
    Next j
    With Me.Cells(58, "V")
        .Value = WorksheetFunction.Sum(Me.Range("F58:U58"))
        .Interior.Color = RGB(255, 255, 0)
        .NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
    End With

    ' 自动调整列宽
    Me.Range(Me.Cells(1, 6), Me.Cells(1, 21)).EntireColumn.AutoFit

    ' 恢复设置
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

关键优化点 #

• 每次循环前重置startRng和EndRng，确保SheetRange是正确的目标区域
• 添加Application.EnableEvents = False，避免修改单元格时递归触发事件
• 移除不必要的Do While循环，减少重复计算
• 找到匹配项后用Exit For退出循环，减少遍历次数
• 使用Me指代当前工作表，避免模糊引用
• 优化行数计算方式，避免因空行导致的错误范围

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