none
Excel VBA - Worksheet Change not running for specified cells RRS feed

  • Question

  • HI There.  I have exhausted all avenues trying to figure out an excel problem.  I have a worksheet with a macro attached.  The macro performs different actions depending on the data entered in specific columns. for example, is a name is entered in column A, date is automatically entered in column B.  When a drop down value is entered in Column L, date is entered in Column L.  If data in column L = "Fees Received" or  "Policy No. Issued" data is copied to another worksheet.  All individual components are working.  However not all the time.  I am new to VBA but believe I have the incorrect logic in my code.  I would be very grateful for any help. 

    Private Sub

    Worksheet_Change(ByVal Target As Range)

    'Dim C As Range, V

    Dim answer As Integer

    Dim LRowCompleted As Integer

    Application.EnableEvents = False

    MsgBox "Target Column is " & Target.Column

    MsgBox "Target Value is " & Target.Value

       

        If Target.Column = 1 Then

            GoTo AddEntryDate

        End If

      

        If Target.Column = 12 Then

            GoTo AddWorkStatusDate

        End If

        If (Target.Column = 12 And Target.Value = "Fees Received") Then

            GoTo FeesReceived

        End If

         

        If (Target.Column = 12 And Target.Value = "Policy No. Issued") Then

            GoTo PolicyNoIssued

        End If

           

       

    Exit Sub

    AddEntryDate:

        'Update on 11/11/2019 -If data changes in column L Activity , insert

        'today's date into column M - Date of Activity

            Dim WorkRng As Range

            Dim rng As Range

            Dim xOffsetColumn As Integer

           

            Set WorkRng = Intersect(Application.ActiveSheet.Range("A:A"), Target)

            xOffsetColumn = 1

           

            If Not WorkRng Is Nothing Then

                Application.EnableEvents = False

                For Each rng In WorkRng

                    If Not VBA.IsEmpty(rng.Value) Then

                        rng.Offset(0, xOffsetColumn).Value = Now

                        rng.Offset(0, xOffsetColumn).NumberFormat = "dd/mm/yyyy"

                        rng.Offset(3, xOffsetColumn).Select

                        With Selection.Interior

                            .Pattern = xlNone

                            .TintAndShade = 0

                            .PatternTintAndShade = 0

                        End With

                    Else

                        rng.Offset(0, xOffsetColumn).ClearContents

                    End If

                Next

                Application.EnableEvents = True

            End If

          

    Exit Sub

    AddWorkStatusDate:

        'Update on 11/11/2019 -If data changes in column L Activity , insert

        'today's date into column M - Date of Activity

            Dim WorkRng2 As Range

            Dim rng2 As Range

            Dim yOffsetColumn As Integer

            Set WorkRng2 = Intersect(Application.ActiveSheet.Range("L:L"), Target)

            yOffsetColumn = 1

            If Not WorkRng2 Is Nothing Then

                Application.EnableEvents = False

                For Each rng2 In WorkRng2

                    If Not VBA.IsEmpty(rng2.Value) Then

                        rng2.Offset(0, yOffsetColumn).Value = Now

                        rng2.Offset(0, yOffsetColumn).NumberFormat = "dd/mm/yyyy"

                    Else

                        rng2.Offset(0, yOffsetColumn).ClearContents

                    End If

                Next

                Application.EnableEvents = True

            End If

    Exit Sub

    PolicyNoIssued:

            Sheets("Income").Select

            LRowCompleted = Sheets("Income").Cells(Rows.Count, "A").End(xlUp).Row '

            'Request confirmation from the user, in form of yes or no

            answer = MsgBox("Do you want to copy this client to the Income Worksheet?", vbQuestion + vbYesNo)

            

            If answer = vbYes Then

                Range("A" & Target.Row & ":A" & Target.Row).Copy

                Sheets("Income").Range("A" & Rows.Count).End(xlUp).Offset(1).Select

                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

                :=False, Transpose:=False

                Application.EnableEvents = True

            Else

                MsgBox "This client will not be copied to the Income Worksheet"

                Application.EnableEvents = True

            End If

     

    Exit Sub

    FeesReceived:

            'Define last row on Income worksheet to know where to place the row of data

            Sheets("Income").Select

            LRowCompleted = Sheets("Income").Cells(Rows.Count, "A").End(xlUp).Row

            'Request confirmation from the user, in form of yes or no

            answer = MsgBox("Do you want to copy this client to the Income Worksheet?", vbQuestion + vbYesNo)

            

            If answer = vbYes Then

                Range("A" & Target.Row & ":A" & Target.Row).Copy

                Sheets("Income").Range("A" & Rows.Count).End(xlUp).Offset(1).Select

                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

                :=False, Transpose:=False

                Application.EnableEvents = True

    Thursday, January 30, 2020 2:49 PM

All replies

  • Move the lines

        If (Target.Column = 12 And Target.Value = "Fees Received") Then
            GoTo FeesReceived
        End If

        If (Target.Column = 12 And Target.Value = "Policy No. Issued") Then
            GoTo PolicyNoIssued
        End If

    to above

        If Target.Column = 12 Then
            GoTo AddWorkStatusDate
        End If


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Thursday, January 30, 2020 8:50 PM