Scribd
Upload
3 views4 pages

Macro interpolation

Uploaded by

urveshdudhat11
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
3 views4 pages

Macro interpolation

Uploaded by

urveshdudhat11
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
You are on page 1/ 4

Function Linterp(ByVal KnownYs As Range, ByVal KnownXs As Range, NewX As Variant)

As Variant
'******************************************************************************
'***DEVELOPER: Ryan Wells (wellsr.com) *
'***DATE: 03/2016 *
'***DESCRIPTION: 2D Linear Interpolation function that automatically picks *
'*** which range to interpolate between based on the closest *
'*** KnownX value to the NewX value you want to interpolate for. *
'***INPUT: KnownYs - 1D range containing your known Y values. *
'*** KnownXs - 1D range containing your known X values. *
'*** NewX - Cell or number with the X value you want to *
'*** interpolate for. *
'***OUTPUT: The output will be the linear interpolated Y value *
'*** corresponding to the NewX value the user selects. *
'***NOTES: i. KnownYs do not have to be sorted. If the values are *
'*** unsorted, the function will linearly interpolate between the *
'*** two closest values to your NewX (one above, one below). *
'*** ii. KnownXs and KnownYs must be the same dimensions. It is a *
'*** good practice to have the Xs and corresponding Ys beside *
'*** each other in Excel before using Linterp. *
'***FORMULA: Linterp=Y0 + (Y1-Y0)*(NewX-X0)/(X1-X0) *
'***EXAMPLE: =Linterp(A2:A4,B2:B4,C2) *
'******************************************************************************

'------------------------------------------------------------------------------
'0. Declare Variables and Initialize Variables
'------------------------------------------------------------------------------
Dim bYRows As Boolean 'Y values are selected in a row (Nx1)
Dim bXRows As Boolean 'X values are selected in a row (Nx1)
Dim DeltaHi As Double 'delta between NewX and KnownXs if Known > NewX
Dim DeltaLo As Double 'delta between NewX and KnownXs if Known < NewX
Dim iHi As Long 'Index position of the closest value above NewX
Dim iLo As Long 'Index position of the closest value below NewX
Dim i As Long 'dummy counter
Dim Y0 As Double, Y1 As Double 'Linear Interpolation Y variables
Dim X0 As Double, X1 As Double 'Linear Interpolation Y variables
iHi = 2147483647
iLo = -2147483648#
DeltaHi = 1.79769313486231E+308
DeltaLo = -1.79769313486231E+308

'------------------------------------------------------------------------------
'I. Preliminary Error Checking
'------------------------------------------------------------------------------
'Error 0 - catch all error
On Error GoTo InterpError:
'Error 1 - NewX more than 1 cell selected
If IsArray(NewX) = True Then
If NewX.Count <> 1 Then
Linterp = "Too many cells in variable NewX."
Exit Function
End If
End If

'Error 2 - NewX is not a number


If IsNumeric(NewX) = False Then
Linterp = "NewX is non-numeric."
Exit Function
End If
'Error 3 - dimensions aren't even
If KnownYs.Count <> KnownXs.Count Or _
KnownYs.Rows.Count <> KnownXs.Rows.Count Or _
KnownYs.Columns.Count <> KnownXs.Columns.Count Then
Linterp = "Known ranges are different dimensions."
Exit Function
End If

'Error 4 - known Ys are not Nx1 or 1xN dimensions


If KnownYs.Rows.Count <> 1 And KnownYs.Columns.Count <> 1 Then
Linterp = "Known Y's should be in a single column or a single row."
Exit Function
End If

'Error 5 - known Xs are not Nx1 or 1xN dimensions


If KnownXs.Rows.Count <> 1 And KnownXs.Columns.Count <> 1 Then
Linterp = "Known X's should be in a single column or a single row."
Exit Function
End If

'Error 6 - Too few known Y cells


If KnownYs.Rows.Count <= 1 And KnownYs.Columns.Count <= 1 Then
Linterp = "Known Y's range must be larger than 1 cell"
Exit Function
End If

'Error 7 - Too few known X cells


If KnownXs.Rows.Count <= 1 And KnownXs.Columns.Count <= 1 Then
Linterp = "Known X's range must be larger than 1 cell"
Exit Function
End If

'Error 8 - Check for non-numeric KnownYs


If KnownYs.Rows.Count > 1 Then
bYRows = True
For i = 1 To KnownYs.Rows.Count
If IsNumeric(KnownYs.Cells(i, 1)) = False Then
Linterp = "One or all Known Y's are non-numeric."
Exit Function
End If
Next i
ElseIf KnownYs.Columns.Count > 1 Then
bYRows = False
For i = 1 To KnownYs.Columns.Count
If IsNumeric(KnownYs.Cells(1, i)) = False Then
Linterp = "One or all KnownYs are non-numeric."
Exit Function
End If
Next i
End If

'Error 9 - Check for non-numeric KnownXs


If KnownXs.Rows.Count > 1 Then
bXRows = True
For i = 1 To KnownXs.Rows.Count
If IsNumeric(KnownXs.Cells(i, 1)) = False Then
Linterp = "One or all Known X's are non-numeric."
Exit Function
End If
Next i
ElseIf KnownXs.Columns.Count > 1 Then
bXRows = False
For i = 1 To KnownXs.Columns.Count
If IsNumeric(KnownXs.Cells(1, i)) = False Then
Linterp = "One or all Known X's are non-numeric."
Exit Function
End If
Next i
End If

'------------------------------------------------------------------------------
'II. Check for nearest values from list of Known X's
'------------------------------------------------------------------------------
If bXRows = True Then 'check by rows
For i = 1 To KnownXs.Rows.Count 'loop through known Xs
If KnownXs.Cells(i, 1) <> "" Then
If KnownXs.Cells(i, 1) > NewX And KnownXs.Cells(i, 1) - NewX < DeltaHi
Then 'determine DeltaHi
DeltaHi = KnownXs.Cells(i, 1) - NewX
iHi = i
ElseIf KnownXs.Cells(i, 1) < NewX And KnownXs.Cells(i, 1) - NewX >
DeltaLo Then 'determine DeltaLo
DeltaLo = KnownXs.Cells(i, 1) - NewX
iLo = i
ElseIf KnownXs.Cells(i, 1) = NewX Then 'match. just report
corresponding Y
Linterp = KnownYs.Cells(i, 1)
Exit Function
End If
End If
Next i
Else ' check by columns
For i = 1 To KnownXs.Columns.Count 'loop through known Xs
If KnownXs.Cells(1, i) <> "" Then
If KnownXs.Cells(1, i) > NewX And KnownXs.Cells(1, i) - NewX < DeltaHi
Then 'determine DeltaHi
DeltaHi = KnownXs.Cells(1, i) - NewX
iHi = i
ElseIf KnownXs.Cells(1, i) < NewX And KnownXs.Cells(1, i) - NewX >
DeltaLo Then 'determine DeltaLo
DeltaLo = KnownXs.Cells(1, i) - NewX
iLo = i
ElseIf KnownXs.Cells(1, i) = NewX Then 'match. just report
corresponding Y
Linterp = KnownYs.Cells(1, i)
Exit Function
End If
End If
Next i
End If

'------------------------------------------------------------------------------
'III. Linear interpolate based on the closest cells in the range. Includes minor
error handling
'------------------------------------------------------------------------------
If iHi = 2147483647 Or iLo = -2147483648# Then
Linterp = "NewX is out of range. Cannot linearly interpolate with the given
Knowns."
Exit Function
End If
If bXRows = True Then
Y0 = KnownYs.Cells(iLo, 1)
Y1 = KnownYs.Cells(iHi, 1)
X0 = KnownXs.Cells(iLo, 1)
X1 = KnownXs.Cells(iHi, 1)
Else
Y0 = KnownYs.Cells(1, iLo)
Y1 = KnownYs.Cells(1, iHi)
X0 = KnownXs.Cells(1, iLo)
X1 = KnownXs.Cells(1, iHi)
End If
Linterp = Y0 + (Y1 - Y0) * (NewX - X0) / (X1 - X0)
Exit Function

'------------------------------------------------------------------------------
'IV. Final Error Handling
'------------------------------------------------------------------------------
InterpError:
Linterp = "Error Encountered: " & Err.Number & ", " & Err.Description
End Function

You might also like