Expand current on change to include multiple target ranges

Question

I have a piece of code that does exactly as I want it to do. Whenever a cell is updated in the column "Contacts 1 Made?" it inputs the date and time into the 2 columns to the right. I want to expand the target range though to include 2 other columns that aren't adjoined. These column headers are;

• Contact 2 Made?
• Contact 3 Made?
• Appointed

I want to same basic principles to apply to these columns. Whenever a cell is updated in any of these columns I want it to do the same thing and input the date and time in the cells to the right.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim KeyCells As Range

Set KeyCells = ActiveSheet.ListObjects("VAMP_P1___P2").ListColumns("Contact 1 Made?").Range

If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then

Application.EnableEvents = False
If Target.Value <> "" Then
ActiveCell.Offset(0, 1).Value = Format(Now(), "dd/mm/yyyy")
ActiveCell.Offset(0, 2).Value = Format(Now(), "hh:mm")
Else
ActiveCell.Offset(0, 1).Value = ""
ActiveCell.Offset(0, 2).Value = ""
End If
    
End If

Application.EnableEvents = True

End Sub

I tried to update the keycell range using the intersect shown below but when it runs it debugs with Invalid procedure call or argument

Set KeyCells = Intersect(ActiveSheet.ListObjects("VAMP_P1___P2").ListColumns("Contact 1 Made?").Range, ActiveSheet.ListObjects("VAMP_P1___P2").ListColumns("Contact 2 Made?").Range)

Answer 1

A Worksheet Change: Date and Time Stamps

Main

Private Sub Worksheet_Change(ByVal Target As Range)

    Const TABLE_NAME As String = "VAMP_P1___P2"
    Const DATE_COLUMN_OFFSET As Long = 1
    Const DATE_FORMAT As String = "dd/mm/yyyy"
    Const TIME_COLUMN_OFFSET As Long = 2
    Const TIME_FORMAT As String = "hh:mm"
    Dim Titles() As Variant: Titles = Array( _
        "Contact 1 Made?", _
        "Contact 2 Made?", _
        "Contact 3 Made?", _
        "Appointed")
        
    Dim trg As Range
        
    With Target
        Dim rg As Range: CombineTableDataColumns rg, _
            .Worksheet.ListObjects(TABLE_NAME), Titles
        Set trg = Intersect(rg, .Cells)
    End With
        
    If trg Is Nothing Then Exit Sub
    
    Dim TimeNow As Date: TimeNow = Now
    Dim DateString As String: DateString = Format(TimeNow, DATE_FORMAT)
    Dim TimeString As String: TimeString = Format(TimeNow, TIME_FORMAT)
    
    Dim srg As Range, crg As Range, cell As Range
    
    For Each cell In trg.Cells
        If Len(CStr(cell.Value)) > 0 Then ' Stamp
            BuildRange srg, cell
        Else ' Clear
            BuildRange crg, cell
        End If
    Next cell
                
    Application.EnableEvents = False
    
    ' Stamp
    If Not srg Is Nothing Then
        With srg
            .Offset(, DATE_COLUMN_OFFSET).Value = DateString
            .Offset(, TIME_COLUMN_OFFSET).Value = TimeString
        End With
    End If
    
    ' Clear
    If Not crg Is Nothing Then
        With crg
            Union(.Offset(, DATE_COLUMN_OFFSET), _
                .Offset(, TIME_COLUMN_OFFSET)).ClearContents
        End With
    End If
    
    Application.EnableEvents = True

End Sub

Help

Sub CombineTableDataColumns( _
        ByRef rg As Range, _
        ByVal tbl As ListObject, _
        Titles() As Variant)
        
    Dim crg As Range, Title As Variant
    
    For Each Title In Titles
        BuildRange rg, tbl.ListColumns(Title).DataBodyRange
    Next Title

End Sub

Sub BuildRange( _
        ByRef rgBuilt As Range, _
        ByVal rgAdd As Range)
    If rgBuilt Is Nothing Then
        Set rgBuilt = rgAdd
    Else
        Set rgBuilt = Union(rgBuilt, rgAdd)
    End If
End Sub

Answer 2

Several recommendations:

• To set up KeyCells, use Union.
• Use Me to refer to the sheet containing this code, not ActiveSheet.
• Use Target to refer to the cell(s) that changed, not ActiveCell.
• Use a loop since Target may be a multi-cell Range.
• Use Target, not Range(Target.Address).
• Create an error handler so that EnableEvents = True is always executed.
• ListColumn.Range includes the header. Probably better to use .DataBodyRange.

Incorporating these:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim Tbl As ListObject
    Set tbl = Me.ListObjects("VAMP_P1__P2")

    Dim KeyCells As Range
    Set KeyCells = Union(tbl.ListColumns("Contact 1 Made?").DataBodyRange, _
                         tbl.ListColumns("Contact 2 Made?").DataBodyRange)

    Dim Rng As Range
    Set Rng = Intersect(KeyCells, Target)

    If Not Rng Is Nothing Then
        On Error GoTo SafeExit
        Application.EnableEvents = False        

        Dim Cell As Range
        For Each Cell In Rng
            If Cell.Value <> "" Then
                Cell.Offset(, 1).Value = Date
                Cell.Offset(, 1).NumberFormat = "dd/mm/yyyy"
                Cell.Offset(, 2).Value = Time
                Cell.Offset(, 2).NumberFormat = "hh:mm"
            Else
                Cell.Offset(, 1).Resize(,2).ClearContents
            End If
        Next
    End If

SafeExit:
    Application.EnableEvents = True
End Sub