Объединить события рабочего листа

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