☰

Создать формулу временной метки для Excel

tag-icon • tag-icon microsoft-excel vba
Создать формулу временной метки для Excel

Идея проста: мне нужна функция, которую я мог бы использовать примерно так =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

Но это все еще не функция.

Я использую Excel из Office 2010.

Спасибо

решение1

Вот полноценное решение, которое позволит вам отслеживать даты изменения разных диапазонов. Обратите внимание, что здесь используется функция изИнструменты Чипа Пирсона для использования массивов в VBAи функционировать изПереполнение стекаответ пользователя Thomas.

Основная идея заключается в том, что глобальный массив, в котором адреса всех отслеживаемых диапазонов (прошлых или настоящих) хранятся с датами их последних обновлений, позволяет функции и подпрограмме Worksheet_Change взаимодействовать. Подпрограмма Worksheet_Change обновляет этот массив, проверяя измененный диапазон по всем сохраненным диапазонам. Функция ищет отслеживаемый диапазон в массиве и возвращает сохраненную дату изменения, если она найдена. В противном случае она возвращает сегодняшнюю дату (которая затем будет добавлена ​​в массив).

Кроме того, чтобы предотвратить потерю временных меток при закрытии рабочей книги и освобождении массива временных меток, массив необходимо записать на лист при событии 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

ПРИМЕЧАНИЕ для тех, кто случайно наткнулся на эту страницу:Многие комментарии касаются предыдущих, неполных решений, поэтому не стоит их путать.

Связанный контент