Record Date values based on another cell's value

I am a beginner in VBA.

I have a Column "A" which can have multiple values, of which 2 are "Impact Assessed" or "Ready for retesting". I want to record the dates when cell's value is changed to Impact Assessed and Ready for Retesting in 2 separate columns - Column B and Column C, respectively. Below is my code -

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

   Dim changedCells As Range
   Set changedCells = Range("A:C")

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

      If Target.Count > 1 Then Exit Sub

      If Target.Column = 1 And LCase(Target.Value) = "Impact Assessed" Then
            Cells(Target.Row, 2) = Date

      ElseIf Target.Column = 1 And LCase(Target.Value) = "Ready" Then
           Cells(Target.Row, 3) = Date

        End If
 End If
End Sub

this is what I have right now

2 answers

  • answered 2020-06-02 00:38 Tim Williams

    You can use something like this:

    Private Sub Worksheet_Change(ByVal Target As Range)
        Dim rng As Range, c As Range
        'If Target.CountLarge > 1 Then Exit Sub
        Set rng = Application.Intersect(Me.Range("A:A"), Target)
        If Not rng Is Nothing Then
            For Each c in rng.cells
                Select Case LCase(c.Value)
                    Case "impact assessed": c.Offset(0, 1).Value = Date
                    Case "ready": c.Offset(0, 2).Value = Date
                End Select
            Next c
        End If
    End Sub

    FYI = Range(Target.Address) is the same (in this case) as Target - no need to get the address just to turn that back into a range.

  • answered 2020-06-02 00:58 Variatus

    I have made the code as versatile as possible. Just change the constants and, if need be, the search criteria in the Criteria variable to suit your worksheet and you can change your sheet as you like without needing to modify the code.

    Private Sub Worksheet_Change(ByVal Target As Range)
        ' 040
        Const TriggerClm    As String = "A"         ' change to suit
        Const WriteToClm    As String = "B"         ' the second one is next to this
        Dim Rng             As Range                ' working range
        Dim C               As Long                 ' WriteToClm
        Dim Criteria()      As String               ' selected values from TriggerClm
        Dim i               As Integer              ' index to Criteria()
        ' don't respond to changes of multiple cells such as Paste or Delete
        If Target.CountLarge > 1 Then Exit Sub
        ' respond to changes in cells from row 2 to
        ' one cell below the last used row in the trigger column
        Set Rng = Range(Cells(2, TriggerClm), _
                        Cells(Rows.Count, TriggerClm).End(xlUp).Offset(1))
        If Not Application.Intersect(Rng, Target) Is Nothing Then
            ' intentionally all lower case because comparison
            ' is carried out case insensitive
            ' First item's date is in WriteToClm
            Criteria = Split("impact assessed,ready for retesting", ",")
            For i = UBound(Criteria) To 0 Step -1
                If StrComp(Target.Value, Criteria(i), vbTextCompare) = 0 Then Exit For
            Next i
            ' i = -1 if no match was found
            If i >= 0 Then
                C = Columns(WriteToClm).Column + i
                Cells(Target.Row, C).Value = Date
            End If
     End If
    End Sub