Function interpol(HYCDate, NewDate, TableTLC As Range)
Application.Volatile 'I think this is the line that slows things down, but your values won't update properly without it (Normally, cells are recalculated automatically if the values in their formula change, however, this function uses cell values which are not in the formula itself; Application.volatile means the formula gets recalculated more frequently).
Dim HYCDateCell As Range, OFST As Long, matdates As Range, YCDates As Range, HYCYields As Range, cll As Range
Dim KnownY1, KnownY2, KnownX1, KnownX2, OldY1, NextY2, OldX1, NextX2, FirstLaterDateFound As Boolean
'First determine where things are so we know where to get values from:
'the following block sets matdates to a range being the top row of dates at the top of the table:
OFST = 1
Do Until Len(TableTLC.Offset(, OFST).Value) = 0
OFST = OFST + 1
Loop
Set matdates = TableTLC.Offset(, 1).Resize(, OFST - 1)
'the following block sets YCDates to a range being the left column of date headers at the left of the table:
OFST = 1
Do Until Len(TableTLC.Offset(OFST).Value) = 0
'If statement to determine row of data to use for extrapolation (instead of doing this in a separate loop):
If TableTLC.Offset(OFST).Value = HYCDate Then
Set HYCDateCell = TableTLC.Offset(OFST)
End If
OFST = OFST + 1
Loop
Set YCDates = TableTLC.Offset(1).Resize(OFST - 1)
'next line sets HYCYields to be the row of data (without row header) from HYCDateCell:
Set HYCYields = HYCDateCell.Offset(, 1).Resize(, matdates.Cells.Count)
'Second, look for values to use in the TREND formula at the end:
With TableTLC.Parent 'Parent identifies the sheet on which the table is.
For Each cll In HYCYields.Cells 'this loop runs through the cells on that one row
If IsNumeric(cll.Value) And Len(cll.Value) > 0 Then 'if the cell has a number in it process it, otherwise move on to the next cll.
Select Case .Cells(TableTLC.Row, cll.Column) 'the date in the header row above the cells being looped through.
Case Is = NewDate '(if the value has the same value as he supplied 2nd argument NewDate then..)
interpol = cll.Value 'no interpolation needed, the value already exists
Exit Function 'no more processing required at all.
Case Is < NewDate '(if the date is earlier than the supplied 2nd argument NewDate then.. (we're looking for the date with a valid value just before the interpolation date))
OldY1 = KnownY1: OldX1 = KnownX1 'this keeps a note of the previous values of KnownY1 and KnownX1 in case later knownY2 is empty.
KnownY1 = cll.Value 'the value in the cell. This is the only line in this section where KnownY1 is assigned a value; it might never be executed if there is no valid value for a date BEFORE the interpolation date (NewDate).
KnownX1 = .Cells(TableTLC.Row, cll.Column).Value 'the date in the header row of dates above the cell cll.
Case Is > NewDate 'if the date is after the interpolation date
'We want the next If statement block to be executed no more than twice.
If FirstLaterDateFound Then
'we want the next 2 lines to be executed no more than once.
NextY2 = cll.Value
NextX2 = .Cells(TableTLC.Row, cll.Column).Value
Else
'we want the next 2 lines to be executed no more than once.
KnownY2 = cll.Value ' this is the only line in this section where KnownY2 is assigned a value; it might never be executed if there is no valid value for a date AFTER the interpolation date (NewDate).
KnownX2 = .Cells(TableTLC.Row, cll.Column).Value
End If
If FirstLaterDateFound Then Exit For ' we've finished getting all the values so quit looking.
FirstLaterDateFound = True 'we've found one date with a valid value after the interpolation date, we'll grab the next pair in case we need to do a backward extrapolation.
End Select
End If
Next cll
End With
'Now to examine what we've got:
If IsEmpty(KnownY2) Then 'KnownY2 can be empty if it has never been assigned a value
KnownY2 = OldY1
KnownX2 = OldX1
End If
If IsEmpty(KnownY1) Then 'KnownY1 can be empty if it has never been assigned a value
KnownY1 = NextY2
KnownX1 = NextX2
End If
'The function hinges on having values for these 5 arguments supplied to the TREND function:
'NewDate, supplied as an argument being the interpolation date
'KnownX1, the date just before the interpolation date with a valid value.
'KnownX2. the date just after the interpolation date with a valid value.
'KnownY1, the value in the row under the date in KnownX1.
'KnownY2, the value in the row under the date in KnownX2.
'We have to cater for several scenarios:
'1. The normal interpolation where we have valid values (neither blank cells nor cells with text in them) and dates either side of the sought date's value.
'2. The case where there is no value BEFORE the sought date's value so we have to extrapolate BACK from the NEXT pair of of valid dates and values.
'3. The case where there is no value AFTER the sought date's value so we need to extrapolate FORWARDS from the PREVIOUS pair of valid dates and values.
'4. Only one date with a valid value in which case no inter/extrapolation can be done.
'5. No date with a valid value in which case no inter/extrapolation can be done.
'Cases 2 and 3 above is what FirstLaterDateFound, NextY2 and NextX2 is all about.
interpol = Application.WorksheetFunction.Trend(Array(KnownY1, KnownY2), Array(CLng(KnownX1), CLng(KnownX2)), CLng(NewDate.Value))
End Function
Reply With Quote
Originally Posted by Red Salerno
