Question

我在这一方面挑战了自己，但到目前为止却失败了。我有两个Worksheet_Change事件，它们是在用户添加数据并在错误的情况下收到弹出消息的相同概念上触发的。

我试图将它们结合起来，但是不断出错。

代码1

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngToCheck As Range
    Dim NumA As Variant, NumB As Variant
    Dim i As Long

    On Error GoTo Whoa

    '~~> Set the relevant range
    Set rngToCheck = Union(Range("G12:G42"), Range("J12:J42"))

    Application.EnableEvents = False

    If Not Intersect(Target, rngToCheck) Is Nothing Then
        For i = 12 To 42 Step 2 '<~~ Loop through only even rows
            NumA = Range("G" & i).Value
            NumB = Range("J" & i).Value

            If IsNumeric(NumA) And IsNumeric(NumB) And NumB <> 0 Then
                If ((NumB - NumA) / NumA) * 100 < 50 Then
                    MsgBox "The Glass U-value and Total System U-value appear very similar. Please check the input values for accuracy!"
                    Exit For
                End If
            End If
        Next i
    End If

Letscontinue:
    Application.EnableEvents = True
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume Letscontinue
End Sub

代码2

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim AffectedRange As Range
    Set AffectedRange = Intersect(Target, Me.Columns(3))

    If Not AffectedRange Is Nothing Then
        Dim Cell As Range
        For Each Cell In AffectedRange

            If Application.WorksheetFunction.CountIf(Me.Columns(3), Cell.Value) > 1 Then
                MsgBox "This Glazing Reference already exists. Please ensure you have a unique reference identifier less than 20 characters in length", vbOKOnly + vbExclamation
            End If

        Next Cell
    End If
End Sub

我希望两个Worksheet_Change事件都运行而不会崩溃。

Answer 1

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngToCheck As Range
    Dim NumA As Variant, NumB As Variant
    Dim i As Long

    On Error GoTo Whoa

    '~~> Set the relevant range
    Set rngToCheck = Union(Range("G12:G42"), Range("J12:J42"))

    Application.EnableEvents = False

    If Not Intersect(Target, rngToCheck) Is Nothing Then
        For i = 12 To 42 Step 2 '<~~ Loop through only even rows
            NumA = Range("G" & i).Value
            NumB = Range("J" & i).Value

            If IsNumeric(NumA) And IsNumeric(NumB) And NumB <> 0 Then
                If ((NumB - NumA) / NumA) * 100 < 50 Then
                    MsgBox "The Glass U-value and Total System U-value appear very similar. Please check the input values for accuracy!"
                    Exit For
                End If
            End If
        Next i
    End If

    Dim AffectedRange As Range
    Set AffectedRange = Intersect(Target, Me.Columns(3))

    If Not AffectedRange Is Nothing Then
        Dim Cell As Range
        For Each Cell In AffectedRange

            If Application.WorksheetFunction.CountIf(Me.Columns(3), Cell.Value) > 1 Then
                MsgBox "This Glazing Reference already exists. Please ensure you have a unique reference identifier less than 20 characters in length", vbOKOnly + vbExclamation
            End If

        Next Cell
    End If

Letscontinue:
    Application.EnableEvents = True
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume Letscontinue
End Su

b

Answer 2

出了什么问题？只是把它们放在一起。

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngToCheck As Range
    Dim NumA As Variant, NumB As Variant
    Dim i As Long

    On Error GoTo Whoa

    '~~> Set the relevant range
    Set rngToCheck = Union(Range("G12:G42"), Range("J12:J42"))

    Application.EnableEvents = False

    If Not Intersect(Target, rngToCheck) Is Nothing Then
        For i = 12 To 42 Step 2 '<~~ Loop through only even rows
            NumA = Range("G" & i).Value
            NumB = Range("J" & i).Value

            If IsNumeric(NumA) And IsNumeric(NumB) And NumB <> 0 Then
                If ((NumB - NumA) / NumA) * 100 < 50 Then
                    MsgBox "The Glass U-value and Total System U-value appear very similar. Please check the input values for accuracy!"
                    Exit For
                End If
            End If
        Next i
    End If


    Dim AffectedRange As Range
    Set AffectedRange = Intersect(Target, Me.Columns(3))

    If Not AffectedRange Is Nothing Then
        Dim Cell As Range
        For Each Cell In AffectedRange

            If Application.WorksheetFunction.CountIf(Me.Columns(3), Cell.Value) > 1 Then
                MsgBox "This Wall Reference already exists. Please ensure you have a unique reference identifier less than 20 characters in length", vbOKOnly + vbExclamation
            End If

        Next Cell
    End If


Letscontinue:
    Application.EnableEvents = True
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume Letscontinue
End Sub

合并工作表事件

2 个答案: