VBA to insert Now() when formula result changes

[fpt264]

I am attempting to write code which will insert Now() in cell L16 whenever the result of the formula in M19 changes due to entries elsewhere on the sheet. In my quest if found code written by mdmackillop posted on this forum which monitors the calculated value in E8 (E6+E7=E8) and repeats that value in E9 and changes the background color of E9 whenever the value in E8 changes due to an entry in E6 or E7. This is the closest thing to what I need that I have been able to find. Here is the code I am referring to:

Option Explicit
 'Create variable to hold values
Dim Monitored
 
Private Sub Worksheet_Activate()
    Monitored = Range("E8").Value 'Read in value prior to any changes
End Sub
 
Private Sub Worksheet_Change(ByVal Target As Range)
     'Check target to determine if macro is triggered
    If Intersect(Target, Union(Range("E6"), Range("E7"))) Is Nothing Then Exit Sub
     'Prevent looping of code due to worksheet changes
    Application.EnableEvents = False
     'Compare monitored cell with initial value
    If Range("E8").Value <> Monitored Then
         'Do things as a result of a change
        DoThings
         'Reset Variable with new monitored value
        Monitored = Range("E8").Value
    End If
     'Reset events
    Application.EnableEvents = True
End Sub
 
Private Sub DoThings()
    With Range("E9")
        .Formula = Range("E6") + Range("E7")
        If .Interior.ColorIndex = 6 Then
            .Interior.ColorIndex = 8
        Else: .Interior.ColorIndex = 6
        End If
    End With
End Sub

So my question is how can I modify this to monitor cell M19 and if its value changes insert Now() in L16?

[excelliot]

why you want to insert

now()

?

[excelliot]

I guess, you need below.. paste this code in worksheet module..

Option Explicit


Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range


    ' The variable KeyCells contains the cells that will
    ' cause an alert when they are changed.
    Set KeyCells = Range("M19")
    
    If Not Application.Intersect(KeyCells, Range(Target.Address)) _
           Is Nothing Then


        ' Display a message when one of the designated cells has been
        ' changed.
        ' Place your code here.
        Range("L16").Value = Time
       
    End If
End Sub

Cheers!!

[fpt264]

Thanks for the reply. This code doesn't change the time when the formula returns a new result but I can change the Key Cells to the range where the data is entered and do it that way.

[mikerickson]

Try this

Private Sub Worksheet_Change(ByVal Target As Range)

    Set KeyCells = Range("M19")

    On Error Resume Next
    Set KeyCells = Application.Union(KeyCells, KeyCells.Precedents)
    On Error Goto 0

    If Not Application.Intersect(Target, KeyCells) Is Nothing Then
        Range("L16").Value = Now
    End If

End Sub

Note that the time stamp will appear anytime that a precedent cell is changed, NOT when the value in M19 is changed.

For example, if M19 has the formula =ABS(A1) and the user changes A1 from -1 to 1, the value in M19 will not be changed, but the time stamp will appear.

[fpt264]

At first I got an error which I was able to correct by adding the line "Dim KeyCells As Range". At this point this appears to insert the date and time (I am using Now() formatted to m/d/yyyy h:mm AM/PM).

If this works like I think it is this would be exactly what I wanted. Thanks for your help.

[fpt264]

mikerickson,
Your code is working as desired, however I find that the time stamp will not update when I have sheet protection on even thought I have unlocked the cell the timestamp goes in. I need to keep Protection on and specific cells unlocked for data entry. Can you suggest a fix for this? Below is the code as I am using it.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range
    Set KeyCells = Range("M19")
    On Error Resume Next
    Set KeyCells = Application.Union(KeyCells, KeyCells.Precedents)
    On Error GoTo 0
    If Not Application.Intersect(Target, KeyCells) Is Nothing Then
        Range("L16").Value = Now
    End If
End Sub

[excelliot]

you can add code before and after for locking & unlocking sheet..

so your code will look like this..

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range
    Set KeyCells = Range("M19")
    On Error Resume Next
    Set KeyCells = Application.Union(KeyCells, KeyCells.Precedents)
    On Error GoTo 0
    If Not Application.Intersect(Target, KeyCells) Is Nothing Then
ActiveSheet.Protect Password:="excelliot"
        Range("L16").Value = Now
ActiveSheet.Unprotect Password:="excelliot"
    End If
End Sub

cheers!!