none
Ignore Worksheet_Event if Excel Row Deleted RRS feed

  • Question

  • I would be very grateful for guidance.  I have a worksheet_change module that carries out different tasks:

    If data entered in Column A, today's date is entered in Column B

    If data entered in Column L, today's date is entered in Column M

    If the value entered in Column L is "Policy No Issued" or " Fees Received", Then The corresponding value in  Column A is added to the end of another worksheet named Income

    The code fails when a row is inserted or deleted.  How can I first check for the insertion and deletion and then continue only if that not the case?  I have attempted it below:  

    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

    Tuesday, February 4, 2020 10:40 PM

All replies

  • To:  YOT Mol
    re:  unhand me

    My first inclination is to put up a UserForm with multiple textboxes for the users to fill in.
    That way you control where the data goes from each textbox.
    You then present the worksheet to the user for confirmation, all he can do is approve, retry or quit.

    Another concept is to pick out the four corners of your set up and enter unique text then validate those 4 cells before continuing.

    Also, is "If ans = False Then Exit For" working for you?
    It should be:  If ans = vbNo Then Exit For
    '---

    Some new, some older Excel programs (now free) at MediaFire...
    Download (no ads) from...

    http://www.mediafire.com/folder/lto3hbhyq0hcf/Documents
    Wednesday, February 5, 2020 12:15 AM