Worksheet_Change handling different actions for different columns of a worksheet not looping correctly

Question

In The following worksheet macro, I am attempting to perform different actions, depending on the column selected. In 2 cases the action performed depends on the Column selected and the column value.

For example, if a name is entered in column A, the date is automatically entered in column B.

When a drop down value is entered in Column L, date is entered in Column M. If data in column L = "Fees Received" or "Policy No. Issued" data is copied to another worksheet and the date is entered in column m.

All individual components are working. However not all the time.

I need the macro to identify the column and perform the correct action such that I can move from column to column and the macro to constantly run in the background and working correctly for all selected columns.

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
        Else
            MsgBox "This client will not be copied to the Income Worksheet"
            Application.EnableEvents = True
        End If
            
            
            
    Application.EnableEvents = True
End Sub

Instead of using `GoTo`, put that code in separate Subroutines and just call the subroutine from the `Worksheet_Change`. `GoTo` can cause [unexpected behavior](https://www.xkcd.com/292/). Also, it's best to [avoid using `.Select`/`.Activate`](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba). — BruceWayne, Jan 30 '20 at 15:36
Nothing is wrong with `GoTo` if it is used properly. `GoTo` should be avoided because of possible spaghetti code. To and Fro `GoTos` can create spaghetti code. But a well structured (Forward Moving) `GoTo` will never create any spaghetti code. Fortunately now there are better ways to manage the code so `GoTo` is rarely used. The only time I use `GoTo` is with OERN or when I need to exit multiple nested loops. :) — Siddharth Rout, Jan 30 '20 at 15:52
[Interesting read on GOTO](https://stackoverflow.com/questions/3517726/what-is-wrong-with-using-goto) — Siddharth Rout, Jan 30 '20 at 15:57
`All individual components are working. However not all the time.` Can you explain this a liitle bit? — Siddharth Rout, Jan 30 '20 at 15:58
Some parts of your code do not seem to account for multi-cell `Target` - you should *always* account for that - eg. you can call `Column` on a multi-cell range and get a value, but that doesn't mean all of Target is in that column.... — Tim Williams, Jan 30 '20 at 16:15

Siddharth Rout · Answer 1 · 2021-11-12T11:10:14.693

From what I can see, you need to monitor only 2 columns. Rest of your requirements is just subsets of those requirements.

Your code can be re-written as below (UNTESTED) Let me know if you get any error? Also since you are working with Worksheet_Change, you may want to see THIS.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim aCell As Range
    Dim wsInc As Worksheet
    Dim lRow As Long
    Dim ans As Variant
    
    On Error GoTo Whoa

    Application.EnableEvents = False
    
    '~~> Check if the change happened in Col A
    If 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

Worksheet_Change handling different actions for different columns of a worksheet not looping correctly

1 Answers1