Attribute VB_Name = "xlInterpolators"
Option Explicit
' Linear and bilinear inter/extrapolators
' shg 1997-2012
'
'
'
Function
Use
---------- -------LInterp
UDF only
of ranges)
' dLInterp
VBA only
Purpose
------UDF wrapper for dLinterp (linear inter/extrapolation
' BiLInterp UDF only
tion of ranges)
' dBiLInterp VBA only
UDF wrapper for dBiLInterp (bilinear inter/extrapola
Linear inter/extrapolator
VBA bilinear inter/extrapolator
'
bInterp
VBA only
Interpolates the non-numeric values of a 1D array in
situ
' InterpArr UDF or VBA UDF wrapper for bInterp
' Sub Interpolate
Interpolates the selected range in situ
' Internal functions
' Frac
VBA only
' NumDim
VBA only
Computes an interpolation fraction
Returns the number of dimensions of an array
Private Function Frac(d As Double, _
avd As Variant, _
ByRef i As Long, _
ByRef dF As Double, _
iMatchType As Long)
' shg 1997-0606, 2009-0419
'
2009-0604 added option for descending sort
' Returns an index to avd in i and an interpolation fraction in dF
' avd must be a 2+ element vector sorted {a|de}scending if iMatchType={1|-1}
If iMatchType = 1 And d <= avd(1) Or _
iMatchType = -1 And d >= avd(1) Then
i = 1
Else
' this can generate an error, handled by caller
i = WorksheetFunction.Match(d, avd, iMatchType)
If i = UBound(avd) Then i = UBound(avd) - 1
End If
dF = (d - avd(i)) / (avd(i + 1) - avd(i))
End Function
Function LInterp(x As Double, rX As Range, rY As Range) As Variant
' UDF wrapper for dLInterp
' shg 1997-0606, 2009-0419
'
2009-0604 added option for descending sort
' rX and rY must be equal-length vectors
' rX must be sorted (ascending or descending, doesn't matter)
Dim avdX
Dim avdY
As Variant
As Variant
On Error GoTo Oops
With WorksheetFunction
If rX.Areas.Count > 1 Then Err.Raise xlErrValue
If rX.Rows.Count <> 1 And rX.Columns.Count <> 1 Then Err.Raise xlErrValu
e
If .Count(rX) <> rX.Cells.Count Then Err.Raise xlErrValue
If rY.Areas.Count > 1 Then Err.Raise xlErrValue
If rY.Rows.Count <> 1 And rY.Columns.Count <> 1 Then Err.Raise xlErrValu
e
If .Count(rY) <> rY.Cells.Count Then Err.Raise xlErrValue
If rX.Cells.Count < 2 Then Err.Raise xlErrValue
If rX.Cells.Count <> rY.Cells.Count Then Err.Raise xlErrValue
If rX.Rows.Count > 1 Then avdX = .Transpose(rX.Value2) Else avdX = .Tran
spose(.Transpose(rX.Value2))
If rY.Rows.Count > 1 Then avdY = .Transpose(rY.Value2) Else avdY = .Tran
spose(.Transpose(rY.Value2))
LInterp = dLInterp(x, avdX, avdY)
End With
Exit Function
Oops:
LInterp = CVErr(Err.Number)
End Function
Function dLInterp(x As Double, avdX As Variant, avdY As Variant) As Double
' Linear interpolator / extrapolator
' {Inter|extra}polates avdX to return the value of avdY corresponding to the
given x
Dim i
Dim dF
As Long
As Double
' index to rY
' interpolation fraction
Frac x, avdX, i, dF, Sgn(avdX(UBound(avdX)) - avdX(1))
dLInterp = avdY(i) * (1 - dF) + avdY(i + 1) * dF
End Function
Public Function BiLInterp(x As Double, _
y As Double, _
rTbl As Range) As Variant
' shg 2007
' UDF wrapper for BiLInterp
Dim rX
Dim rY
As Range
As Range
Dim avdX
Dim avdY
Dim avdZ
As Variant
As Variant
As Variant
' top row of rTbl
' left column of rTbl
On Error GoTo Oops
If rTbl.Areas.Count > 1 Then Err.Raise xlErrValue
If rTbl.Rows.Count < 3 Or rTbl.Columns.Count < 3 Then Err.Raise xlErrValue
With WorksheetFunction
' If .Count(rTbl) - .Count(rTbl(1)) <> rTbl.Cells.Count - 1 Then Err.Rai
se xlErrValue
Set rX = Range(rTbl(1, 2), rTbl(1, rTbl.Columns.Count))
Set rY = Range(rTbl(2, 1), rTbl(rTbl.Rows.Count, 1))
avdX = .Transpose(.Transpose(rX.Value))
avdY = .Transpose(rY.Value)
avdZ = Range(rTbl(2, 2), rTbl(rTbl.Rows.Count, rTbl.Columns.Count)).Valu
e2
BiLInterp = dBiLInterp(x, y, avdX, avdY, avdZ)
End With
Exit Function
Oops:
BiLInterp = CVErr(Err.Number)
End Function
Function dBiLInterp(x As Double, y As Double, _
avdX As Variant, avdY As Variant, _
avdZ As Variant)
' shg 1997-0606, 2007-0307, 2009-0419
'
2009-0615 added support for ascending or descending sort
'
2009-1021 changed implementation of weighted sum
'
2011-1228 fix a bug in computing iMatchType!
' Returns the bilinear interpolation of rTbl with
' o x interpolated across the top row (rX)
' o y interpolated down the left column (rY)
' x and y must be within the upper and lower limits of rX and rY
' rTbl must be sorted
' o
left to right by the top row
' o
top to bottom by the left column
' The sort orders can be ascending or descending,
' each independent of the other.
' All values in rTbl must be numeric (other than the UL corner,
' which is ignored).
Dim
Dim
Dim
Dim
iRow
iCol
dRF
dCF
As
As
As
As
Long
Long
Double
Double
' row fraction
' column fraction
Frac x, avdX, iCol, dCF, Sgn(avdX(UBound(avdX)) - avdX(1))
Frac y, avdY, iRow, dRF, Sgn(avdY(UBound(avdY)) - avdY(1))
' weighted sum of four
dBiLInterp = avdZ(iRow
avdZ(iRow
avdZ(iRow
avdZ(iRow
End Function
corners
+ 0, iCol
+ 0, iCol
+ 1, iCol
+ 1, iCol
+
+
+
+
0)
1)
0)
1)
*
*
*
*
(1# - dRF)
(1# - dRF)
(dRF - 0#)
(dRF - 0#)
*
*
*
*
(1# - dCF) + _
(dCF - 0#) + _
(1# - dCF) + _
(dCF - 0#)
'===============================================================================
Function bLInterp(avInp As Variant) As Boolean
' shg 2010, 2012
' VBA only
'
'
'
'
Interpolates between the numeric values in 1D array avInp in situ
Non-numeric values (Empty, text, logical, or errors)
are replaced by linear interpolation or extrapolation of the adjacent
numeric values.
' Returns False if avInp is not 1D, or contains fewer than two numbers.
' UDF or VBA
' For example =InterpArr({"", "", 1, "", 3, "", "", 9, ""})
'
returns
{-1, 0, 1, 2, 3, 5, 7, 9, 11}
' Requires NumDim
Dim
Dim
Dim
Dim
Dim
Dim
iLB
iUB
iInp
nNum
aiNum()
iNum
Dim dF
As
As
As
As
As
As
Long
Long
Long
Long
Long
Long
As Double
'
'
'
'
'
'
lower bound of avInp
upper bound of avInp
index to avInp
count of numbers in avInp
stores the indices of numeric values in avInp
index to aiNum
' interpolating fraction
If NumDim(avInp) > 1 Then Exit Function
With WorksheetFunction
nNum = .Count(avInp)
If nNum < 2 Then Exit Function
ReDim aiNum(1 To nNum)
iLB = LBound(avInp)
iUB = UBound(avInp)
For iInp = iLB To iUB
If .IsNumber(avInp(iInp)) Then
iNum = iNum + 1
aiNum(iNum) = iInp
End If
Next iInp
End With
iNum = 1
For iInp = iLB To iUB
If iInp > aiNum(iNum + 1) Then
If iNum < nNum - 1 Then iNum = iNum + 1
End If
dF = (iInp - aiNum(iNum)) / (aiNum(iNum + 1) - aiNum(iNum))
avInp(iInp) = (1 - dF) * avInp(aiNum(iNum)) + dF * avInp(aiNum(iNum + 1)
)
Next iInp
bLInterp = True
End Function
Function InterpArray(avInp As Variant) As Variant
' shg 2010, 2012
' UDF wrapper for bInterp
Dim av
As Variant
Dim r
As Range
Set r = Application.Caller
If r.Areas.Count > 1 Or (r.Rows.Count > 1 And r.Columns.Count > 1) Then
InterpArray = CVErr(xlErrValue)
Else
With WorksheetFunction
av = avInp
If NumDim(av) > 1 Then av = .Transpose(av)
If NumDim(av) > 1 Then av = .Transpose(av)
If NumDim(av) > 1 Then
InterpArray = CVErr(xlErrValue)
Else
bLInterp av
If r.Rows.Count = 1 Then
InterpArray = av
Else
InterpArray = .Transpose(av)
End If
End If
End With
End If
End Function
Sub Interpolate()
' shg 2012
' Interpolates the selected range in situ
' Requires bLInterp
Dim r
As Range
Dim av
As Variant
If TypeOf Selection Is Range Then
Set r = Selection
If r.Areas.Count > 1 Or (r.Rows.Count > 1 And r.Columns.Count > 1) Then
MsgBox "Must select a single-area, single-row or single-column range
!"
Else
With WorksheetFunction
If r.Rows.Count = 1 Then
av = .Transpose(.Transpose(r.Value))
bLInterp av
r.Value = av
Else
av = .Transpose(r.Value)
bLInterp av
r.Value = .Transpose(av)
End If
End With
End If
Else
MsgBox "Must select a range!"
End If
End Sub
Private Function NumDim(av As Variant) As Long
Dim i
As Long
If TypeOf av Is Range Then
If av.Count = 1 Then NumDim = 1 Else NumDim = 2
ElseIf IsArray(av) Then
On Error GoTo Done
For NumDim = 0 To 6000
i = LBound(av, NumDim + 1)
Next NumDim
Done:
Err.Clear
End If
End Function
