My 2 c: кэшировать массивы прошлых значений и времен (для каждой ячейки) в словаре stati c и просматривать их каждый раз, когда функция вызывается для указанной c ячейки.
Это немного сложный вопрос, поскольку требование «last 30 se c» означает, что функция должна выполняться на регулярной основе, но если входные данные не изменяются, то выход функции останется как есть. Даже сделать его нестабильным - это не решение, если ничего не обновляется на листе. (Если ваши входные данные обновляются на регулярной основе, возможно, вам не нужно Application.Volatile)
Использование (например, в B2)
=MaxInLast(30, A2)
UDF:
Function MaxInLast(numSecs As Long, rng As Range)
Static dict As Object, tmp
Dim arrTimes, arrValues, addr As String, v
Application.Volatile 'otherwise will never update without
' a change to the inputs...
If dict Is Nothing Then Set dict = CreateObject("scripting.dictionary")
Set rng = rng.Cells(1) 'make sure we're only working with 1 cell
addr = rng.Address
v = rng.Value
If Not dict.exists(addr) Then
dict(addr) = Array(Array(), Array()) 'set up for this cell
End If
tmp = dict(addr) 'existing or new arrays for this cell
arrTimes = tmp(0) 'times
arrValues = tmp(1) 'values
Debug.Print "Before clean", addr, Join(arrValues, ",")
RemoveStaleAndAddValue arrTimes, arrValues, v, numSecs
Debug.Print "After clean", addr, Join(arrValues, ",")
If UBound(arrTimes) <> -1 Then
MaxInLast = Application.Max(arrValues)
Else
MaxInLast = "" 'no data
End If
dict(addr) = Array(arrTimes, arrValues) 'cache new state
End Function
' Gets references to the time/value arrays
' Cleans the arrays of "stale" values and appends any new value
' Returns new data via ByRef arguments
Sub RemoveStaleAndAddValue(ByRef arrTimes, ByRef arrValues, v, secs As Long)
Dim tmpTimes, tmpValues, ub, n As Long, i As Long
ub = UBound(arrTimes)
ReDim tmpTimes(0 To ub + 1) 'new arrays for cleaned data
ReDim tmpValues(0 To ub + 1)
i = 0
For n = 0 To ub
If Timer - arrTimes(n) <= secs Then 'value still fresh?
tmpTimes(i) = arrTimes(n)
tmpValues(i) = arrValues(n)
i = i + 1
End If
Next
If Len(v) > 0 And IsNumeric(v) Then 'new value to add?
tmpTimes(i) = Timer
tmpValues(i) = v
i = i + 1
End If
If i > 0 Then
'resize to fit content and set ByRef arguments
ReDim Preserve tmpTimes(0 To i - 1)
arrTimes = tmpTimes
ReDim Preserve tmpValues(0 To i - 1)
arrValues = tmpValues
Else
'no data, just set empty arrays
arrTimes = Array()
arrValues = Array()
End If
End Sub
Function MaxInLast(numSecs As Long, rng As Range)
Static dict As Object, tmp
Dim arrTimes, arrValues, i, mx, addr As String, haveValue As Boolean, v
Application.Volatile 'otherwise will never update without a change to the inputs...
If dict Is Nothing Then Set dict = CreateObject("scripting.dictionary")
Set rng = rng.Cells(1) 'make sure we're only working with 1 cell
addr = rng.Address
v = rng.Value
If Not dict.exists(rng.Address) Then
dict(addr) = Array(Array(), Array()) 'set up for this cell
End If
tmp = dict(addr) 'existing or new arrays for this cell
arrTimes = tmp(0) 'times
arrValues = tmp(1) 'values
Debug.Print "Before clean", addr, Join(arrValues, ",")
RemoveStaleAndAddValue arrTimes, arrValues, v, numSecs
Debug.Print "After clean", addr, Join(arrValues, ",")
If UBound(arrTimes) <> -1 Then
MaxInLast = Application.Max(arrValues)
Else
MaxInLast = "" 'no data
End If
dict(addr) = Array(arrTimes, arrValues) 'cache new state
End Function
' Gets references to the time/value arrays
' Cleans the arrays of "stale" values and appends any new value
' Returns new data via ByRef arguments
Sub RemoveStaleAndAddValue(ByRef arrTimes, ByRef arrValues, v, secs As Long)
Dim tmpTimes, tmpValues, ub, n As Long, i As Long
ub = UBound(arrTimes)
ReDim tmpTimes(0 To ub + 1) 'new arrays for cleaned data
ReDim tmpValues(0 To ub + 1)
i = 0
For n = 0 To ub
If Timer - arrTimes(n) <= secs Then 'value still fresh?
tmpTimes(i) = arrTimes(n)
tmpValues(i) = arrValues(n)
i = i + 1
End If
Next
If Len(v) > 0 And IsNumeric(v) Then 'new value to add?
tmpTimes(i) = Timer
tmpValues(i) = v
i = i + 1
End If
If i > 0 Then
'resize to fit content and set ByRef arguments
ReDim Preserve tmpTimes(0 To i - 1)
arrTimes = tmpTimes
ReDim Preserve tmpValues(0 To i - 1)
arrValues = tmpValues
Else
'no data, just set empty arrays
arrTimes = Array()
arrValues = Array()
End If
End Sub