Предотвращение неожиданного запуска EventChange Sub

Question

Советы будут с благодарностью. Я занимаюсь разработкой электронной таблицы с использованием Excel 2016 / Windows.

Я написал 4 подпрограммы для обмена событиями, и все они работают хорошо. Код VBA для рабочего листа проверяет 4 события. События 1, 2 и 3 вводят сегодняшнюю дату в ячейку, если данные вводятся в другую ячейку (код не указан ниже)

Код для EventChange работает нормально, но иногда работает, когда этого не ожидается!

EventChange4 перемещает значение из одной ячейки в другую, если другая ячейка содержит текст в столбце J «ЭТОТ МЕСЯЦ - Срок платежа» или «Выпущено, но не оплачено». Вторая часть этого события exchange4 перемещает нулевое значение в 2 ячейки, если данные в столбце j содержат текст "не идет вперед"

Я новичок в VBA. Проблема в том, что eventchange4 запускается без видимой причины, например, копирование значения ячейки в столбце H в другую ячейку в столбце ч. Как я могу изменить код так, чтобы eventchange4 запускался только при изменении данных в столбце J? Все советы с благодарностью приняты !!!!

Private Sub Worksheet_Change(ByVal Target As Range)
Call EventChange_1(Target) 
Call EventChange_2(Target)
Call EventChange_3(Target)
Call EventChange_4(Target)
End Sub
Sub EventChange_1(ByVal Target As Range)
'Update on 11/11/2019 -If data changes in column L, insert
'today's date into column M

End Sub
Sub EventChange_2(ByVal Target As Range)
'Update  on 15/01/2020 -If data changes in column P, insert today's date
'into next Column Q

End Sub
Sub EventChange_3(ByVal Target As Range)
'Update on 15/01/2020 -If data changes in column R, insert today's date
'into next Column S

End Sub

Sub EventChange_4(ByVal Target As Range)
    On Error Resume Next
    Application.EnableEvents = False
' this works !

    If Target.Column = 10 And (Target.Value = "THIS Month – Payment Due" Or Target.Value = "Issued But Not Paid") Then
        Range("K" & Target.Row).Value = Range("I" & Target.Row).Value
        Range("I" & Target.Row).Clear
        MsgBox "Moved Commission Due to Month Paid"
    End If
    If Target.Column = 10 And (Target.Value = "Not Going Ahead") Then
        Range("I" & Target.Row).Value = 0
        Range("K" & Target.Row).Value = 0
        MsgBox "Moved ZERO to Initial Commisson and Month Paid"
    End If
    Application.EnableEvents = True
End Sub

Answer 1

В идеале вы должны обновить свой код, чтобы он мог правильно обрабатывать целевой диапазон, который не является просто одной ячейкой:

Sub EventChange_4(ByVal Target As Range)

    Dim rng As Range, c As Range, v

    'any part of Target in Column J?
    Set rng = Application.Intersect(Target, Me.Columns(10))

    If Not rng Is Nothing Then
        'have some cells to process...
        On Error GoTo haveError
        Application.EnableEvents = False
        'process each affected cell in Col J
        For Each c In rng.Cells
            v = c.Value
            If v = "THIS Month – Payment Due" Or v = "Issued But Not Paid" Then
                Range("K" & c.Row).Value = Range("I" & c.Row).Value
                Range("I" & c.Row).Clear
                MsgBox "Moved Commission Due to Month Paid"
            End If
            If v = "Not Going Ahead" Then
                Range("I" & c.Row).Value = 0
                Range("K" & c.Row).Value = 0
                MsgBox "Moved ZERO to Initial Commisson and Month Paid"
            End If
        Next c
    End If
haveError:
    Application.EnableEvents = True
End Sub

ПРИМЕЧАНИЕ : предполагается, что он находится в соответствующем модуль кода рабочего листа - в противном случае вы должны квалифицировать вызовы Range() с указанием c ссылки на рабочий лист.

Все ваши обработчики изменений должны следовать аналогичному шаблону.

Answer 2

Тим извиняется. Я новичок в этом и очень хотел получить решение. Благодарю за ваш ответ. Совет отметил. T

Когда я пытаюсь вставить или удалить строку в электронной таблице, код VBA идентифицирует событие рабочего листа и пытается выполнить код. Электронная таблица вылетает. Я попытался добавить код, который предотвратит это, проверив в начале модуля, была ли строка вставлена ​​или удалена перед другим событием изменения рабочего листа, если проверены операторы

Спасибо

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim aCell As Range
    Dim wsInc As Worksheet
    Dim count As Integer
    Dim lRow As Long
    Dim ans As Variant
    Dim tb As ListObject

    On Error GoTo Whoa

    Application.EnableEvents = False
    Set tb = ActiveSheet.ListObjects(1)
    MsgBox Target.Rows.count

    If tb.Range.Cells.count > count Then
      count = tb.Range.Cells.count
'      GoTo Whoa
    ElseIf tb.Range.Cells.count < count Then
      count = tb.Range.Cells.count
'      GoTo Whoa
   '~~> Check if the change happened in Col A
    ElseIf Not Intersect(Target, Columns(1)) Is Nothing Then
        For Each aCell In Target.Cells
            With aCell
                If Len(Trim(.Value)) = 0 Then
                    .Offset(, 1).ClearContents
                Else
                    .Offset(, 1).NumberFormat = "dd/mm/yyyy"
                    .Offset(, 1).Value = Now
                    With .Interior
                        .Pattern = xlNone
                        .TintAndShade = 0
                        .PatternTintAndShade = 0
                    End With
                End If
            End With
        Next
    '~~> Check if the change happened in Col L
    ElseIf Not Intersect(Target, Columns(12)) Is Nothing Then
        Set wsInc = Sheets("Income")
        lRow = wsInc.Range("A" & wsInc.Rows.count).End(xlUp).Row + 1

        For Each aCell In Target.Cells
            With aCell
                If Len(Trim(.Value)) = 0 Then
                    .Offset(, 1).ClearContents
                Else
                    .Offset(, 1).NumberFormat = "dd/mm/yyyy"
                    .Offset(, 1).Value = Now
                    With .Interior
                        .Pattern = xlNone
                        .TintAndShade = 0
                        .PatternTintAndShade = 0
                    End With

                    '~~> Check of the value is Fees Received, Policy No. Issued
                    If .Value = "Fees Received" Or .Value = "Policy No. Issued" Then
                        ans = MsgBox("Do you want to copy this client to the Income Worksheet?", vbQuestion + vbYesNo)

                        If ans = False Then Exit For

                        wsInc.Range("A" & lRow).Value = Range("A" & aCell.Row).Value
                    End If
                End If
            End With
        Next
    End If

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