[英]Automatically enter date & time as cell is updated/changed
I want the macro to automatically record the time and date on the empty cell on right IF the "cell of interest" changes values through a formula. 如果“感兴趣的细胞”通过公式改变值,我希望宏在右侧的空单元格上自动记录时间和日期 。
eg IF cell("k3") changes values, THEN register DATE & TIME when it changed on cell ("L3"); 例如,IF单元(“k3”)改变值,然后在单元格上改变时注册DATE&TIME(“L3”); IF cell("L3") IS NOT empty, THEN register the TIME & DATE in cell("M3"), and so forth until it finds an empty cell.
IF单元(“L3”)不为空,然后在单元(“M3”)中注册TIME和DATE,依此类推,直到找到空单元。
So far, I have not been able to prompt the macro whenever the "cell of interest" changes values. 到目前为止,每当“感兴趣的细胞”改变值时,我都无法提示宏。 PS: the latter is an IF formula that outputs 2 possible strings: "OK" and "ISSUE RISK WARNING"
PS:后者是IF公式 ,输出2个可能的字符串:“OK”和“ISSUE RISK WARNING”
Private sub Register_timestamp(ByVal Target As Range)
'This sub registers the date and hour at which the cells in column K:K changed values.
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("K:K"))
xOffsetColumn = 1
If WorkRng Is Nothing Then
Application.EnableEvents = False
For Each Rng In WorkRng
If Not VBA.IsEmpty(Rng.Value) Then
Rng.Offset(0, xOffsetColumn).Value = Now
Rng.Offset(0, xOffsetColumn).NumberFormat = "dd-mm-yyyy, hh:mm:ss"
Else
xOffsetColumn = xOffsetColumn + 1
End If
Next
Application.EnableEvents = True
End If
End sub
If I were to manually change the cell that is subject to the "cell of interest"'s IF Function - and triggers it -, the date and time at which the "cell of interest" changed, eg: 14/05/2019 21:44:21 如果我要手动更改受“感兴趣的细胞”的IF功能影响的细胞 - 并触发它 - ,“感兴趣的细胞”发生变化的日期和时间,例如: 14/05/2019 21 :44:21
Here's how you'd implement my suggestions. 以下是您实施我的建议的方式。 Make sure this code is on the correct worksheet's code module.
确保此代码位于正确的工作表代码模块上。
Private Sub Worksheet_Calculate()
Dim rMonitored As Range
Dim MonitoredCell As Range
Dim vSelected As Variant
Dim aNewValues As Variant
Dim ixFormulaCell As Long
On Error Resume Next
Set rMonitored = Me.Columns("K").SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If rMonitored Is Nothing Then Exit Sub 'No formula cells in column K
Application.EnableEvents = False 'Disable events to prevent infinite calc loop
Set vSelected = Selection 'Remember current selection (it may not be a range)
'Prepare the array that will store the new values, the cells those values are in, and whether or not there was a change
ReDim aNewValues(1 To rMonitored.Cells.Count, 1 To 3)
'Column1 = new value
'Column2 = cell address
'Column3 = did value change?
'Get the new value for each formula in column K
ixFormulaCell = 0
For Each MonitoredCell In rMonitored.Cells 'The formula cells may not be in a contiguous range
ixFormulaCell = ixFormulaCell + 1
aNewValues(ixFormulaCell, 1) = MonitoredCell.Value 'Store the new value
Set aNewValues(ixFormulaCell, 2) = MonitoredCell 'Store the cell address
Next MonitoredCell
Application.Undo 'This will undo the most recent change, which allows us to compare the new vs old to check for formula updates
ixFormulaCell = 0
For Each MonitoredCell In rMonitored.Cells
ixFormulaCell = ixFormulaCell + 1
'Check if the formula result is different
If MonitoredCell.Value <> aNewValues(ixFormulaCell, 1) Then
'Formula result found to be different, record that
'We can't put the timestamp in now because we still have to redo the most recent change
aNewValues(ixFormulaCell, 3) = True
End If
Next MonitoredCell
Application.Undo 'Redo the most recent change to put worksheet back in the new state
'Now that we've completed our comparison and have re-done the most recent change, check what did change and put in a timestamp in the next empty cell in same row
For ixFormulaCell = LBound(aNewValues, 1) To UBound(aNewValues, 1)
'Check for formula result change
If aNewValues(ixFormulaCell, 3) Then
'Formula result change found, get next empty cell in same row
With Me.Cells(aNewValues(ixFormulaCell, 2).Row, Me.Columns.Count).End(xlToLeft).Offset(, 1)
'Next empty cell found, put in the current datetime stamp and format it
.Value = Now
.NumberFormat = "dd-mm-yyyy, hh:mm:ss"
End With
End If
Next ixFormulaCell
vSelected.Select 'Re-select the remembered selection so that this operation is invisible to users
Application.EnableEvents = True 'Re-enable events so that the next calculation can be monitored for formula changes in cells of interest
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.