Excel VBA 工作表更改崩溃

Question

我尝试运行工作表更改宏，似乎当我在其中一个单元格中出现错误（由于列表中的数据验证）然后单击工作表中的其他位置时，excel 崩溃了。

此工作表有工作表更改宏，我认为由于这个原因，它一直在崩溃。有人可以帮忙吗？谢谢。

   
Option Explicit
Dim Monitored



'Private Sub Worksheet_Activate()
    'Monitored = Sheet1.Range("C110").Value 'Read in value prior to any changes
'End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

Application.ScreenUpdating = False
Dim KeyCells As Range
Dim KeyCells2 As Range
'Regelmäßigkeit
Set KeyCells = Sheet1.Range("A1:M157")

If Not Application.Intersect(KeyCells, Range(Target.Address)) _
           Is Nothing Then

If Sheet1.Range("L38").Value = "Nein" Then
    Sheet1.Rows("42:44").Hidden = True
   
ElseIf Sheet1.Range("L38").Value = "Ja" Then
    Sheet1.Rows("42:44").Hidden = False
    
End If

'Keine extra Frage
If Sheet1.Range("C99").Value = "17. Bitte beachten Sie folgende Besonderheiten:" Then
    Sheet1.Rows("98:103").Hidden = True
'Extra Frage
ElseIf Sheet1.Range("C99").Value <> "17. Bitte beachten Sie folgende Besonderheiten:" Then
    Sheet1.Rows("98:103").Hidden = False

End If

Dim lastRow As Long
Dim sumX As Long
Dim result As String
Dim sumXY As Long


'Keine Extra Frage
If Sheet1.Rows("98:103").Hidden = True Then

'Unvollständig
If Application.WorksheetFunction.CountIf(Sheet1.Range("P1:P97"), "X") > 0 Then
    Sheet1.Range("C106").Value = Sheet2.Range("A53").Value
ElseIf Application.WorksheetFunction.CountIf(Sheet1.Range("P1:P97"), "X") = 0 Then

        'Check if the value in E25 is in Sheet2 column G
        If Application.WorksheetFunction.CountIf(Sheet2.Range("H3:H229"), Sheet1.Range("E25").Value) > 0 Then
            'If the value is found, sum the values in O1:O98
            sumX = Application.WorksheetFunction.CountIf(Sheet1.Range("O1:O97"), "X")


            If sumX = 16 Then
                'Wenn Summe gleich 16 ist, dann genehmigt
                Sheet1.Range("C106").Value = Sheet2.Range("A33").Value
            ElseIf sumX < 16 Then
                'Wenn Summe ungleich 16 ist, dann mit Vorbehalt
                Sheet1.Range("C106").Value = Sheet2.Range("A43").Value
            End If
        Else
                Sheet1.Range("C106").Value = Sheet2.Range("A43").Value
        End If
End If

'Extra Frage
ElseIf Sheet1.Rows("98:103").Hidden = False Then

'Unvollständig
If Application.WorksheetFunction.CountIf(Sheet1.Range("P1:P99"), "X") > 0 Then
    Sheet1.Range("C106").Value = Sheet2.Range("A53").Value

ElseIf Application.WorksheetFunction.CountIf(Sheet1.Range("P1:P99"), "X") = 0 Then

        'Check if the value in E25 is in Sheet2 column G
        If Application.WorksheetFunction.CountIf(Sheet2.Range("H3:H229"), Sheet1.Range("E25").Value) > 0 Then
            'If the value is found, sum the values in O1:O98
            sumX = Application.WorksheetFunction.CountIf(Sheet1.Range("O1:O99"), "X")
    
            If sumX = 17 Then
                'Wenn Summe gleich 17 ist, dann genehmigt
                Sheet1.Range("C106").Value = Sheet2.Range("A33").Value
            ElseIf sumX < 17 Then
                'Wenn Summe ungleich 17 ist, dann mit Vorbehalt
                Sheet1.Range("C106").Value = Sheet2.Range("A43").Value
            End If
        Else
                Sheet1.Range("C106").Value = Sheet2.Range("A43").Value

        End If
End If
End If


'Colour coding
If Sheet1.Range("C106").Value = Sheet2.Range("A33").Value Then
Sheet1.Range("C106").Interior.ColorIndex = 43
ElseIf Sheet1.Range("C106").Value = Sheet2.Range("A43").Value Then
Sheet1.Range("C106").Interior.ColorIndex = 44
ElseIf Sheet1.Range("C106").Value = Sheet2.Range("A53").Value Then
Sheet1.Range("C106").Interior.ColorIndex = 46
End If

End If

End Sub

Answer 1

如果在使用 worksheet 事件 时出现 Out of Stack space 错误，您必须关闭 event handler，即在开头添加

Application.EnableEvents = False

。当然，您应该在代码结束时再次打开它。

如果您不关闭事件处理程序，

worksheet_change

事件将被一次又一次地调用，因为您更改了工作表中的值。只要堆栈空间可用，这就会发生

我通常这样编码

Private Sub Worksheet_Change(ByVal Target As Range)

    On Error GoTo EH
    Application.EnableEvents = False

    ' code which should run
EH:
    ' just to make sure that Events get triggered again
    ' even in case there is an error in the previous code
    Application.EnableEvents = True
    
End Sub