-
Notifications
You must be signed in to change notification settings - Fork 0
/
excel-linterp
191 lines (178 loc) · 7.48 KB
/
excel-linterp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
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