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
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
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.
I have made the code as versatile as possible. Just change the constants and, if need be, the search criteria in the
Criteriavariable 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