当单元格中的值更改时，私有子更新日期自动

Question

Im trying to automatically update current date in cell T when text in cell Q is "won" and a value in cell AM is > 0. I tried the code below and it is working if first the value in cell is > 0 and then you update the text in cell Q BUT if you do it in another way (first update cell Q and secondly the value in cell AM) the date doesn't appear in cell T.

Any idea, what Im I missing?

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [Q:Q]) Is Nothing Then
    If UCase(Target) = UCase("won") And Target.Offset(, 22) > 0 Then
        Target.Offset(, 2) = Int(Now())
    End If
    End If
End sub

Answer 1

Your code only checks for changes in Q therefore the update does not take place if you change AM first.

My solution has three parts:

1. use constants for the columns - in case there are changes to the sheet layout you only have to make adjustments here
2. worksheet_change: only check if one of the columns is affected then call the according sub - by that the reader of the code immediately understands what is going on here
3. the main routine that inserts the date if condition is met or removes the date if not (maybe you want to adjust this)

Option explicit

Private Const colStatus As String = "Q"
Private Const colValue As String = "AM"
Private Const colDateWon As String = "S"


Private Sub Worksheet_Change(ByVal Target As Range)

Dim c As Range
Set c = Target.Cells(1, 1)

If c.Column = Me.Columns(colStatus).Column Or c.Column = Me.Columns(colValue).Column Then
    updateDateWon c.row
End If
End Sub


Private Sub updateDateWon(row As Long)
'--> adjust the name of the sub to your needs

Dim valueToInsert As Variant
With Me
    If .Range(colStatus & row) = "won" And .Range(colValue & row) > 0 Then
         valueToInsert = Int(Now)
    Else
        'reset the date in case conditions are not met
        valueToInsert = vbNullString
    End If
    Application.EnableEvents = False   'disable events so that change-event isn't called twice
    .Range(colDateWon & row) = valueToInsert
    Application.EnableEvents = True
End With

End Sub

Answer 2

A Worksheet Change Applied to Two Non-Adjacent Columns

• You need to monitor columns Q and AM for changes.
• You need to account for Target being multiple adjacent and non-adjacent cells.
• You need to disable events when writing to the worksheet containing this code to not retrigger this event (or trigger any other events).
• It is good practice to ensure the re-enabling of events (by using error-handling).
• You can combine the cells to be written to ( dCell ) into a range ( drg ) and write the stamp in one go.
• Int(Now()) or Int(Now) is actually Date .

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    On Error GoTo ClearError

    Const sColsAddress As String = "Q:Q,AM:AM"
    Const dCol As String = "T"
    Const fRow As Long = 2 ' (e.g. 2 for excluding headers in the first row)
    Const sCriteria As String = "won"
    
    Dim srg As Range
    With Range(sColsAddress)
        Set srg = Intersect(.Cells, Rows(fRow).Resize(Rows.Count - fRow + 1))
    End With
    
    Dim sirg As Range: Set sirg = Intersect(srg, Target)
    If sirg Is Nothing Then Exit Sub
    
    Dim sirg1 As Range: Set sirg1 = Intersect(sirg.EntireRow, srg.Areas(1))
    Dim siCol2 As Long: siCol2 = srg.Areas(2).Column
    'Dim dirg As Range: Set dirg = sirg1.EntireRow.Columns(dCol) ' not used
    
    Dim siCell1 As Range
    Dim siValue2 As Variant
    Dim drg As Range
    
    For Each siCell1 In sirg1.Cells
        If StrComp(CStr(siCell1.Value), sCriteria, vbTextCompare) = 0 Then
            siValue2 = siCell1.EntireRow.Columns(siCol2).Value
            If IsNumeric(siValue2) Then
                If siValue2 > 0 Then
                    If drg Is Nothing Then
                        Set drg = siCell1.EntireRow.Columns(dCol)
                    Else
                        Set drg = Union(drg, siCell1.EntireRow.Columns(dCol))
                    End If
                End If
            End If
        End If
    Next siCell1
    
    If Not drg Is Nothing Then
        ' Prevent retriggering the event when writing to the worksheet.
        Application.EnableEvents = False
        drg.Value = Now ' only after testing, use 'dDate = Date'
    End If
    
SafeExit:
    ' Enable events 'at all cost'.
    If Not Application.EnableEvents Then Application.EnableEvents = True
    
    Exit Sub
ClearError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    Resume SafeExit
End Sub