这个想法很简单,我想要一个可以做类似事情的功能=MOD_DATE_OF(A1:A4)
,当该范围内的任何单元格被修改时,我分配该公式的单元格就会获取当前日期。
我在网上发现了一些类似的问题,甚至这里,但没有一个相当。
我最接近的是在某处得到的这个代码(抱歉,忘记了来源):
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Column = 1 Then
Target.Offset(0, 1).Value = Date
End If
End Sub
但它仍然不是一个功能..
我使用的是 Office 2010 中的 Excel
谢谢
答案1
这是一个成熟的解决方案,可让您监控不同范围的更改日期。请注意,这使用来自Chip Pearson 在 VBA 中使用数组的工具并发挥作用堆栈溢出用户 Thomas 的回答。
基本思想是,一个全局数组允许函数和 Worksheet_Change Sub 进行交互,其中存储了所有受监控范围(过去或现在)的地址及其最新更新日期。Worksheet_Change Sub 通过检查更改的范围与所有存储的范围来更新此数组。该函数在数组中查找受监控的范围,如果找到,则返回存储的更改日期。否则,它将返回今天的日期(然后将添加到数组中)。
此外,为了防止在关闭工作簿并释放时间戳数组时丢失时间戳,必须在 Workbook_Close 事件中将数组写入工作表,然后在 Workbook_Open 事件中将数组重写到数组中。
在模块中,粘贴以下代码。
Public funcInstances() As Variant
Public Function MOD_DATE_OF(monitor As Range)
Application.Volatile True
Dim i As Long
Dim tmpArray() As Variant
If Not IsDimensioned(funcInstances) Then
ReDim funcInstances(1 To 1, 1 To 2) As Variant
funcInstances(1, 1) = monitor.Address
funcInstances(1, 2) = Date
Else
For i = 1 To UBound(funcInstances, 1)
If funcInstances(i, 1) = monitor.Address Then
MOD_DATE_OF = Format(funcInstances(i, 2), "yyyy-mm-dd")
Exit Function
End If
Next i
tmpArray = ExpandArray(funcInstances, 1, 1, "")
Erase funcInstances
funcInstances = tmpArray
funcInstances(UBound(funcInstances, 1), 1) = monitor.Address
funcInstances(UBound(funcInstances, 1), 2) = Date
End If
MOD_DATE_OF = Format(funcInstances(UBound(funcInstances, 1), 2), "yyyy-mm-dd")
End Function
'ExpandArray() is the work of Chip Pearson. Code copied from http://www.cpearson.com/excel/vbaarrays.htm
Function ExpandArray(Arr As Variant, WhichDim As Long, AdditionalElements As Long, _
FillValue As Variant) As Variant
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ExpandArray
' This expands a two-dimensional array in either dimension. It returns the result
' array if successful, or NULL if an error occurred. The original array is never
' changed.
' Parameters:
' --------------------
' Arr is the array to be expanded.
'
' WhichDim is either 1 for additional rows or 2 for
' additional columns.
'
' AdditionalElements is the number of additional rows or columns
' to create.
'
' FillValue is the value to which the new array elements should be
' initialized.
'
' You can nest calls to Expand array to expand both the number of rows and
' columns. E.g.,
'
' C = ExpandArray(ExpandArray(Arr:=A, WhichDim:=1, AdditionalElements:=3, FillValue:="R"), _
' WhichDim:=2, AdditionalElements:=4, FillValue:="C")
' This first adds three rows at the bottom of the array, and then adds four
' columns on the right of the array.
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Result As Variant
Dim RowNdx As Long
Dim ColNdx As Long
Dim ResultRowNdx As Long
Dim ResultColNdx As Long
Dim NumRows As Long
Dim NumCols As Long
Dim NewUBound As Long
Const ROWS_ As Long = 1
Const COLS_ As Long = 2
''''''''''''''''''''''''''''
' Ensure Arr is an array.
''''''''''''''''''''''''''''
If IsArray(Arr) = False Then
ExpandArray = Null
Exit Function
End If
'''''''''''''''''''''''''''''''''
' Ensure the dimension is 1 or 2.
'''''''''''''''''''''''''''''''''
Select Case WhichDim
Case 1, 2
Case Else
ExpandArray = Null
Exit Function
End Select
''''''''''''''''''''''''''''''''''''
' Ensure AdditionalElements is > 0.
' If AdditionalElements < 0, return NULL.
' If AdditionalElements = 0, return Arr.
''''''''''''''''''''''''''''''''''''
If AdditionalElements < 0 Then
ExpandArray = Null
Exit Function
End If
If AdditionalElements = 0 Then
ExpandArray = Arr
Exit Function
End If
NumRows = UBound(Arr, 1) - LBound(Arr, 1) + 1
NumCols = UBound(Arr, 2) - LBound(Arr, 2) + 1
If WhichDim = ROWS_ Then
'''''''''''''''
' Redim Result.
'''''''''''''''
ReDim Result(LBound(Arr, 1) To UBound(Arr, 1) + AdditionalElements, LBound(Arr, 2) To UBound(Arr, 2))
''''''''''''''''''''''''''''''
' Transfer Arr array to Result
''''''''''''''''''''''''''''''
For RowNdx = LBound(Arr, 1) To UBound(Arr, 1)
For ColNdx = LBound(Arr, 2) To UBound(Arr, 2)
Result(RowNdx, ColNdx) = Arr(RowNdx, ColNdx)
Next ColNdx
Next RowNdx
'''''''''''''''''''''''''''''''
' Fill the rest of the result
' array with FillValue.
'''''''''''''''''''''''''''''''
For RowNdx = UBound(Arr, 1) + 1 To UBound(Result, 1)
For ColNdx = LBound(Arr, 2) To UBound(Arr, 2)
Result(RowNdx, ColNdx) = FillValue
Next ColNdx
Next RowNdx
Else
'''''''''''''''
' Redim Result.
'''''''''''''''
ReDim Result(LBound(Arr, 1) To UBound(Arr, 1), UBound(Arr, 2) + AdditionalElements)
''''''''''''''''''''''''''''''
' Transfer Arr array to Result
''''''''''''''''''''''''''''''
For RowNdx = LBound(Arr, 1) To UBound(Arr, 1)
For ColNdx = LBound(Arr, 2) To UBound(Arr, 2)
Result(RowNdx, ColNdx) = Arr(RowNdx, ColNdx)
Next ColNdx
Next RowNdx
'''''''''''''''''''''''''''''''
' Fill the rest of the result
' array with FillValue.
'''''''''''''''''''''''''''''''
For RowNdx = LBound(Arr, 1) To UBound(Arr, 1)
For ColNdx = UBound(Arr, 2) + 1 To UBound(Result, 2)
Result(RowNdx, ColNdx) = FillValue
Next ColNdx
Next RowNdx
End If
''''''''''''''''''''
' Return the result.
''''''''''''''''''''
ExpandArray = Result
End Function
'IsDimensioned() is the work of StackOverflow user @Thomas. Code copied from https://stackoverflow.com/a/5480690/657668
Public Function IsDimensioned(vValue As Variant) As Boolean
On Error Resume Next
If Not IsArray(vValue) Then Exit Function
Dim i As Integer
i = UBound(vValue)
IsDimensioned = Err.Number = 0
End Function
在适当的工作表模块中,粘贴以下代码。
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim j As Long
If IsDimensioned(funcInstances) Then
For j = 1 To UBound(funcInstances, 1)
If Not Intersect(Target, Range(funcInstances(j, 1))) Is Nothing Then
funcInstances(j, 2) = Date
End If
Next j
Me.Calculate
End If
Application.EnableEvents = True
End Sub
最后,在ThisWorkbook模块中粘贴以下代码:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If IsDimensioned(funcInstances) Then
Application.ScreenUpdating = False
'Store array on a new temporary and hidden worksheet.
Dim tmpS As Worksheet, tmpR As Range
Set tmpS = Worksheets.Add
tmpS.Name = "TEMP Record of Timestamps"
tmpS.Visible = xlSheetHidden
Set tmpR = tmpS.Range("A1:B1").Resize(UBound(funcInstances, 1), 2)
tmpR.Value = funcInstances
ThisWorkbook.Save
Application.ScreenUpdating = True
End If
End Sub
Private Sub Workbook_Open()
Dim ws As Worksheet, tstamps As Range
Dim wsfound As Boolean
wsfound = False
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name = "TEMP Record of Timestamps" Then
wsfound = True
Exit For
End If
Next ws
If wsfound Then
Set tstamps = ws.UsedRange
funcInstances = tstamps.Value
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Application.ScreenUpdating = True
End Sub
对于偶然发现此页面的人请注意:许多评论都是关于以前不完整的解决方案的,所以不要被它们混淆。