Auto cell update with use of intersect

Question

So basically I have a column in my spreadsheet that tracks the status of bearing conditions. 800+ bearings spread across 8 or so sheets (different areas of a facility) and will continue to increase in the future.

There is a corresponding column that tracks the date that the status last changed.

I have several active x controls and user forms on a dashboard/homepage for the work book that allow the user to make these changes automatically, however I would like to be able to go into the sheets and manually change the status (drop down list) and have the date in corresponding cell change automatically.

I found some code I modified and it appears to work which is good

    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    Dim xRg As Range, xCell As Range
    On Error Resume Next
    If (Target.Count = 1) Then
        If (Not Application.Intersect(Target, Me.Range("G5:G80")) Is Nothing) Then _
            Target.Offset(0, 1) = Date
        Application.EnableEvents = False
        Set xRg = Application.Intersect(Target.Dependents, Me.Range("G5:G80"))
        If (Not xRg Is Nothing) Then
            For Each xCell In xRg
                xCell.Offset(0, 1) = Date
            Next
        End If
        Application.EnableEvents = True
    End If
End Sub

Having got the code working as I wanted I realised I would like it to to add the date to additional cells in that row but dependent on what the cell is changed to (for example if the cell is change to "Good" also add the current date in a cell offset by 4).

I have modified the code further and it now also adding the date too cells dependent on what the change value was.

    Private Sub Worksheet_Change(ByVal Target As Excel.Range)

    Dim xRg As Range, xCell As Range
    Dim UpperIndex As Integer
    Dim LowerIndex As Integer
    Dim Rows As Integer
    
       
    Set tbl = ThisWorkbook.Worksheets("Route 1").ListObjects("Route_1_Table")
    Rows = tbl.Range.Rows.Count
    UpperIndex = 5
    LowerIndex = Rows - 3
    
    
    On Error Resume Next
    If (Target.Count = 1) Then
        If (Not Application.Intersect(Target, Me.Range("G" & UpperIndex & ":G" & LowerIndex)) Is Nothing) Then _
            Target.Offset(0, 1) = Date
            If Target.Value = "Good" Then _
            Target.Offset(0, 5) = Date
            If Target.Value = "Pending Baseline" Then _
            Target.Offset(0, 4) = Date
    End If
End Sub

As you can see I removed the last section of the code but I don't know what it did, any ideas? Just wondering if it comes back to bite me later. Bit removed shown below

        Application.EnableEvents = False
        Set xRg = Application.Intersect(Target.Dependents, Me.Range("G5:G80"))
        If (Not xRg Is Nothing) Then
            For Each xCell In xRg
                xCell.Offset(0, 1) = Date
            Next
        End If
        Application.EnableEvents = True

Answer 1

A Worksheet Change: Date Stamp To Multiple Columns

Sheet Module e.g. Sheet1

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    AddDateStamp Target, "Route_1_Table", 7, 8, 3, 3, _
        Array(11, "Pending Baseline"), Array(12, "Good")
End Sub

Standard Module e.g. Module1

Option Explicit

Sub AddDateStamp( _
        ByVal Target As Range, _
        ByVal TargetTableName As String, _
        ByVal TargetColumn As Long, _
        ByVal DateColumn As Long, _
        ByVal TopRowsSkipped As Long, _
        ByVal BottomRowsSkipped As Long, _
        ParamArray DateColumnCriteriaPairs() As Variant)

    On Error GoTo ClearError ' start error-handling routine
    
    Dim tws As Worksheet: Set tws = Target.Worksheet
    Dim trg As Range: Set trg = tws.ListObjects(TargetTableName).DataBodyRange
    
    ' Exclude top and bottom rows.
    Set trg = trg.Resize(trg.Rows.Count - TopRowsSkipped - BottomRowsSkipped) _
        .Offset(TopRowsSkipped)
    
    ' Reference the intersecting cells.
    Dim irg As Range: Set irg = Intersect(trg.Columns(TargetColumn), Target)
    If irg Is Nothing Then Exit Sub ' no intersection
    
    Dim AnyDcPairs As Boolean
    AnyDcPairs = Not IsMissing(DateColumnCriteriaPairs)
    
    Dim dcIndex As Long, ccIndex As Long ' Date Column Index
    
    If AnyDcPairs Then
        dcIndex _
            = LBound(DateColumnCriteriaPairs(LBound(DateColumnCriteriaPairs)))
        ccIndex _
            = UBound(DateColumnCriteriaPairs(LBound(DateColumnCriteriaPairs)))
    End If
    
    Dim urg As Range, iCell As Range, dcPair, iString As String
    
    For Each iCell In irg.Cells
        Set urg = RefCombinedRange( _
            urg, iCell.Offset(, DateColumn - TargetColumn))
        iString = CStr(iCell.Value)
        If AnyDcPairs Then
            For Each dcPair In DateColumnCriteriaPairs
                If StrComp(iString, dcPair(ccIndex), vbTextCompare) = 0 Then
                    Set urg = RefCombinedRange( _
                        urg, iCell.Offset(, dcPair(dcIndex) - TargetColumn))
                    Exit For ' match found, stop looping
                End If
            Next dcPair
        End If
    Next iCell
    
    Application.EnableEvents = False
    
    urg.Value = Date
    
ProcExit: ' Exit Routine
    On Error Resume Next ' prevent endless loop if error in the following lines
        If Not Application.EnableEvents Then Application.EnableEvents = True
    On Error GoTo 0
    Exit Sub ' don't forget!
ClearError: ' continue error-handling routine
    Debug.Print "Run-time error '" & Err.Number & "':" & vbLf & Err.Description
    Resume ProcExit ' redirect to exit routine
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      References a range combined from two ranges.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCombinedRange( _
    ByVal urg As Range, _
    ByVal arg As Range) _
As Range
    If urg Is Nothing Then Set urg = arg Else Set urg = Union(urg, arg)
    Set RefCombinedRange = urg
End Function