need some help for linear interpolation


C

choi1chung1gm

Dear Kind People,

I need to linearly interpolate two points (X0,Y0) & (X1,Y1) to find
the New_Y value for a given New_X. The X's value increases as i go
down in column A. Say I want to find New_Y for New_X = 0.7895. I want
to lookup the two closest values of X's that New_X = 0.7895 is
between(0.7892 and 0.7897) and then use these two points to linearly
interpolate the Ys to get New_Y for New_X = 0.7895.

Example data set -

A B C D

X Y New_X New_Y

1 0.782 2.1417 0.782
2 0.7831 2.1474 0.7839
3 0.7842 2.1532 0.7858
4 0.7853 2.1592 0.7876
5 0.7864 2.1653 0.7895
6 0.7875 2.1715 0.7914
7 0.7881 2.1746 0.7932
8 0.7886 2.1778 0.7951
9 0.7892 2.181 0.797
10 0.7897 2.1843 0.7988
11 0.7908 2.1908 0.8069
12 0.7919 2.1974 0.8007 2.0298
13 0.793 2.2042
14 0.7936 2.2076
15 0.7941 2.211
16 0.7947 2.2144
17 0.7952 2.2179
18 0.7958 2.2214
19 0.7963 2.2248
20 0.7974 2.2318
21 0.7979 2.2354
22 0.7985 2.2389
23 0.799 2.2424
24 0.7996 2.246
25 0.8001 2.0321
26 0.8007 2.0298


I have a VBScript (please see at the end of this message within the
#### borders) that extracts the X and Y columns from a text file. I
need help to take it further to do the following -

(A) create column C of New_X values as follows -

- put value in C1 equal to that in A1 (or the first X)
- calculate the difference between last X and first X values (e.g.
0.8007-0.782 = 0.0187)
- calculate values for 10 cells C2, C3,...C11 using formula (C2 = C1
+ 0.0187/10), (C3=C2+0.0187/10),...(C11 = C10 + 0.0187/10)
- put C12=last X (in this example C12=0.8007) and put D12= last Y (in
this example 2.0298)

(B) A macro/VBScript to populate column D (D1 to D11) based on linear
interpolation as explained above.

I searched thru this listserve (to do the part (B)) and found
following post by Ron Rosenfeld (11/29/2005) and it works perfectly as
Excel sheet formula to get New_Y values (but I need a vb script to do
the same on the fly in my code).

=IF(NewX=MAX(x_s),MAX(y_s),VLOOKUP(NewX,tbl,2)+
(INDEX(tbl,MATCH(VLOOKUP(NewX,tbl,1),x_s)+2,2)-
VLOOKUP(NewX,tbl,2))*(NewX-VLOOKUP(NewX,tbl,1))
/(INDEX(tbl,MATCH(VLOOKUP(NewX,tbl,1),x_s)+2,1)-
VLOOKUP(NewX,tbl,1)))


I also found a VbScript by Dana DeLouis (8/11/1998) as shown below
between the asterick borders. I think that it will work for me but I
just don't understand it fully. I don't know how to call this Function
in my existing macro or how to pass the values of X (same as s1data()
in my code below), Y (same as s2data() in my code below) and New_X to
it to do the linear interpolation. Please help. Thank you all kind
people very much in advance.

Choi

***************************************************************************
' Code from Dana DeLouis

Hello. Here is a copy of 1 custom interpolating function that I use.
Most
of the code is error checking. The actual code is rather small. You
can
remove most of the error checking if you want. The code searches
Xrange to
find the 2 surrounding values close to 'Value' and interpolates along
the
Yrange to return an answer. Xrange (& Yrange) is a column of data
like
A1:A10. You do not have to manually pick the 2 surrounding Xvalues.
Note
the use of Value2 in the code. This allows you to search for a date
(just
like you want).
Any questions? Just ask. Hope this helps.

Function Interpolate(Value, XRange As Range, YRange As Range,
Optional
X_Ascending As Boolean = True)
'// Dana DeLouis: (e-mail address removed)
'// Value is the number to interpolate along the XRange
'// XRange & YRange are the table data
'// (each 1 column wide, with at least 2 rows)
'// Include X_Ascending = False if XRange in Descending order
'// otherwise, default is XRange in Ascending order


Application.Volatile
Dim Ys
Dim Xs
Dim P As Integer
On Error Resume Next


'// Adjust Value if a Date
If IsDate(Value) Then Value = CDbl(CDate(Value))


'// Check X Range for errors
If XRange.Columns.Count > 1 Or XRange.Rows.Count < 2 Then
Interpolate = "** Error, X Range"
Exit Function
End If


'// Check Y Range for errors
If YRange.Columns.Count > 1 Or YRange.Rows.Count < 2 Then
Interpolate = "** Error, Y Range"
Exit Function
End If


'// Make sure X & Y have same # of rows
If XRange.Rows.Count <> YRange.Rows.Count Then
Interpolate = "** Error, # Rows"
Exit Function
End If


With WorksheetFunction
'// Look for an exact match first
P = .Match(Value, XRange.Value2, 0) '** 0 for an exact match
If P > 0 Then
'An exact match. Just get given data
Interpolate = .Index(YRange, P, 1)
Else
If X_Ascending = True Then
P = .Match(Value, XRange.Value2, 1) '** 1 for
ascending
order!
Else
P = .Match(Value, XRange.Value2, -1) '** -1 for
descending
order!
End If


'// Make sure number falls inside XRange
'// otherwise answer may not be valid
If P = 0 Or P = XRange.Cells.Count Then
Interpolate = "# outside range"
Exit Function
End If


'// Pick surrounding cells to do a linear interpolation
Xs = Array(.Index(XRange.Value2, P,
1), .Index(XRange.Value2, P
+ 1, 1))
Ys = Array(.Index(YRange.Value2, P,
1), .Index(YRange.Value2, P
+ 1, 1))
Interpolate = .Forecast(Value, Ys, Xs)
End If
End With
End Function
***************************************************************************

##########################################################################
'choi's code

Option Explicit

Sub ProcessText()

Dim FName, FNameO As Variant
Dim MyTitle, MyFilter As String
Dim FNum As Long
Dim sLine As String
Dim i, j, k, l As Long
Dim x As Variant
Dim s1data(), s2data() As Variant


FNum = FreeFile
ReDim s1data(1 To 50000, 1 To 1)
ReDim s2data(1 To 50000, 1 To 1)
Close FNum
Imax = 1
MyTitle = "Select File(s)"
MyFilter = "MXV Files (*.mxv), *.mxv"
' MyFilter = "All Files (*.*), *.*"

Application.ScreenUpdating = False


ChDir "C:\" 'This is the starting directory to lookup files


FName = Application.GetOpenFilename(FileFilter:=MyFilter, _
Title:=MyTitle, MultiSelect:=True)


If IsArray(FName) Then
For k = LBound(FName) To UBound(FName)

Open FName(k) For Input As FNum
i = 1
Do While Not InStr(1, sLine, "TheCell # 22", vbTextCompare) > 0
Line Input #FNum, sLine
i = i + 1
Loop

Debug.Print sLine

For i = 1 To 300
Line Input #FNum, sLine
Next i

Debug.Print sLine

i = 1
Do While Not InStr(1, sLine, "EndCell# 22", vbTextCompare) > 0
Line Input #FNum, sLine
s1data(i, 1) = Right(sLine, Len(sLine) - InStr(1, sLine, "
"))
s2data(i, 1) = Left(sLine, Len(sLine) - InStr(1, sLine, "
"))
i = i + 1
Loop


Close FNum

'START_Write output
i = i - 2
ActiveWorkbook.Sheets(1).Activate
For j = 1 To i
Cells(j , 1).Value = s1data(j, 1)
Cells(j , 2).Value = s2data(j, 1)
Next j

End Sub
##########################################################################
 
Ad

Advertisements

G

Guest

Your code never writes the new x values to the worksheet. If they are
already there then after you write the s1Data and s2Data to the sheet, you
would walk through the list of newX values.

ActiveWorkbook.Sheets(1).Activate
For j = 1 To i
Cells(j, 1).Value = s1data(j, 1)
Cells(j, 2).Value = s2data(j, 1)
Next j
set rngX = Range(Cells(1,1),Cells(1,1).End(xldown))
set rngY = rngX.offset(0,1)
set NewX = Range(cells(1,3),Cells(1,3).End(xldown))
for each cell in NewX
cell.offset(0,1) = Interpolate(cell,rngX,rngY,True)
Next
Next
 
Ad

Advertisements

N

Niek Otten

' =========================================================================

Function TableInterpol(ToFind As Double, Table As Range, ResultColumnNr As Long, _
Optional SortDir, Optional KeyColumnNr)
' Niek Otten, March 22 2006
' Works like Vlookup, but interpolates and has some extra options
' 1st argument: Key to look for. Numbers only!
' 2nd argument: Range to look in and get the result from. Numbers only!
' 3rd argument: Relative column number in the range to extract the result from
' Optional 4th argument: defaults to: "Ascending"; any supplied argument forces Descending
' Optional 5th argument: Relative column number in the range to search the key in,
' defaults to 1

Dim RowNrLow As Long
Dim RowNrHigh As Long
Dim ResultLow As Double
Dim ResultHigh As Double
Dim KeyFoundLow As Double
Dim KeyFoundHigh As Double

If IsMissing(SortDir) Then
SortDir = 1
Else
SortDir = -1
End If

If IsMissing(KeyColumnNr) Then
KeyColumnNr = 1
End If

RowNrLow = Application.WorksheetFunction.Match(ToFind, Intersect(Table, Table.Cells(KeyColumnNr). _
EntireColumn), SortDir)
ResultLow = Table(RowNrLow, ResultColumnNr)

If ToFind = ResultLow Then
TableInterpol = Table(RowNrLow, ResultColumnNr)
Exit Function ' avoid unnesssary second MATCH() call if already exact match found
End If

RowNrHigh = RowNrLow + 1
ResultHigh = Table(RowNrHigh, ResultColumnNr)
KeyFoundLow = Table(RowNrLow, KeyColumnNr)
KeyFoundHigh = Table(RowNrHigh, KeyColumnNr)
TableInterpol = ResultLow + (ToFind - KeyFoundLow) / (KeyFoundHigh - KeyFoundLow) _
* (ResultHigh - ResultLow)

End Function
' =========================================================================



--
Kind regards,

Niek Otten
Microsoft MVP - Excel

| Dear Kind People,
|
| I need to linearly interpolate two points (X0,Y0) & (X1,Y1) to find
| the New_Y value for a given New_X. The X's value increases as i go
| down in column A. Say I want to find New_Y for New_X = 0.7895. I want
| to lookup the two closest values of X's that New_X = 0.7895 is
| between(0.7892 and 0.7897) and then use these two points to linearly
| interpolate the Ys to get New_Y for New_X = 0.7895.
|
| Example data set -
|
| A B C D
|
| X Y New_X New_Y
|
| 1 0.782 2.1417 0.782
| 2 0.7831 2.1474 0.7839
| 3 0.7842 2.1532 0.7858
| 4 0.7853 2.1592 0.7876
| 5 0.7864 2.1653 0.7895
| 6 0.7875 2.1715 0.7914
| 7 0.7881 2.1746 0.7932
| 8 0.7886 2.1778 0.7951
| 9 0.7892 2.181 0.797
| 10 0.7897 2.1843 0.7988
| 11 0.7908 2.1908 0.8069
| 12 0.7919 2.1974 0.8007 2.0298
| 13 0.793 2.2042
| 14 0.7936 2.2076
| 15 0.7941 2.211
| 16 0.7947 2.2144
| 17 0.7952 2.2179
| 18 0.7958 2.2214
| 19 0.7963 2.2248
| 20 0.7974 2.2318
| 21 0.7979 2.2354
| 22 0.7985 2.2389
| 23 0.799 2.2424
| 24 0.7996 2.246
| 25 0.8001 2.0321
| 26 0.8007 2.0298
|
|
| I have a VBScript (please see at the end of this message within the
| #### borders) that extracts the X and Y columns from a text file. I
| need help to take it further to do the following -
|
| (A) create column C of New_X values as follows -
|
| - put value in C1 equal to that in A1 (or the first X)
| - calculate the difference between last X and first X values (e.g.
| 0.8007-0.782 = 0.0187)
| - calculate values for 10 cells C2, C3,...C11 using formula (C2 = C1
| + 0.0187/10), (C3=C2+0.0187/10),...(C11 = C10 + 0.0187/10)
| - put C12=last X (in this example C12=0.8007) and put D12= last Y (in
| this example 2.0298)
|
| (B) A macro/VBScript to populate column D (D1 to D11) based on linear
| interpolation as explained above.
|
| I searched thru this listserve (to do the part (B)) and found
| following post by Ron Rosenfeld (11/29/2005) and it works perfectly as
| Excel sheet formula to get New_Y values (but I need a vb script to do
| the same on the fly in my code).
|
| =IF(NewX=MAX(x_s),MAX(y_s),VLOOKUP(NewX,tbl,2)+
| (INDEX(tbl,MATCH(VLOOKUP(NewX,tbl,1),x_s)+2,2)-
| VLOOKUP(NewX,tbl,2))*(NewX-VLOOKUP(NewX,tbl,1))
| /(INDEX(tbl,MATCH(VLOOKUP(NewX,tbl,1),x_s)+2,1)-
| VLOOKUP(NewX,tbl,1)))
|
|
| I also found a VbScript by Dana DeLouis (8/11/1998) as shown below
| between the asterick borders. I think that it will work for me but I
| just don't understand it fully. I don't know how to call this Function
| in my existing macro or how to pass the values of X (same as s1data()
| in my code below), Y (same as s2data() in my code below) and New_X to
| it to do the linear interpolation. Please help. Thank you all kind
| people very much in advance.
|
| Choi
|
| ***************************************************************************
| ' Code from Dana DeLouis
|
| Hello. Here is a copy of 1 custom interpolating function that I use.
| Most
| of the code is error checking. The actual code is rather small. You
| can
| remove most of the error checking if you want. The code searches
| Xrange to
| find the 2 surrounding values close to 'Value' and interpolates along
| the
| Yrange to return an answer. Xrange (& Yrange) is a column of data
| like
| A1:A10. You do not have to manually pick the 2 surrounding Xvalues.
| Note
| the use of Value2 in the code. This allows you to search for a date
| (just
| like you want).
| Any questions? Just ask. Hope this helps.
|
| Function Interpolate(Value, XRange As Range, YRange As Range,
| Optional
| X_Ascending As Boolean = True)
| '// Dana DeLouis: (e-mail address removed)
| '// Value is the number to interpolate along the XRange
| '// XRange & YRange are the table data
| '// (each 1 column wide, with at least 2 rows)
| '// Include X_Ascending = False if XRange in Descending order
| '// otherwise, default is XRange in Ascending order
|
|
| Application.Volatile
| Dim Ys
| Dim Xs
| Dim P As Integer
| On Error Resume Next
|
|
| '// Adjust Value if a Date
| If IsDate(Value) Then Value = CDbl(CDate(Value))
|
|
| '// Check X Range for errors
| If XRange.Columns.Count > 1 Or XRange.Rows.Count < 2 Then
| Interpolate = "** Error, X Range"
| Exit Function
| End If
|
|
| '// Check Y Range for errors
| If YRange.Columns.Count > 1 Or YRange.Rows.Count < 2 Then
| Interpolate = "** Error, Y Range"
| Exit Function
| End If
|
|
| '// Make sure X & Y have same # of rows
| If XRange.Rows.Count <> YRange.Rows.Count Then
| Interpolate = "** Error, # Rows"
| Exit Function
| End If
|
|
| With WorksheetFunction
| '// Look for an exact match first
| P = .Match(Value, XRange.Value2, 0) '** 0 for an exact match
| If P > 0 Then
| 'An exact match. Just get given data
| Interpolate = .Index(YRange, P, 1)
| Else
| If X_Ascending = True Then
| P = .Match(Value, XRange.Value2, 1) '** 1 for
| ascending
| order!
| Else
| P = .Match(Value, XRange.Value2, -1) '** -1 for
| descending
| order!
| End If
|
|
| '// Make sure number falls inside XRange
| '// otherwise answer may not be valid
| If P = 0 Or P = XRange.Cells.Count Then
| Interpolate = "# outside range"
| Exit Function
| End If
|
|
| '// Pick surrounding cells to do a linear interpolation
| Xs = Array(.Index(XRange.Value2, P,
| 1), .Index(XRange.Value2, P
| + 1, 1))
| Ys = Array(.Index(YRange.Value2, P,
| 1), .Index(YRange.Value2, P
| + 1, 1))
| Interpolate = .Forecast(Value, Ys, Xs)
| End If
| End With
| End Function
| ***************************************************************************
|
| ##########################################################################
| 'choi's code
|
| Option Explicit
|
| Sub ProcessText()
|
| Dim FName, FNameO As Variant
| Dim MyTitle, MyFilter As String
| Dim FNum As Long
| Dim sLine As String
| Dim i, j, k, l As Long
| Dim x As Variant
| Dim s1data(), s2data() As Variant
|
|
| FNum = FreeFile
| ReDim s1data(1 To 50000, 1 To 1)
| ReDim s2data(1 To 50000, 1 To 1)
| Close FNum
| Imax = 1
| MyTitle = "Select File(s)"
| MyFilter = "MXV Files (*.mxv), *.mxv"
| ' MyFilter = "All Files (*.*), *.*"
|
| Application.ScreenUpdating = False
|
|
| ChDir "C:\" 'This is the starting directory to lookup files
|
|
| FName = Application.GetOpenFilename(FileFilter:=MyFilter, _
| Title:=MyTitle, MultiSelect:=True)
|
|
| If IsArray(FName) Then
| For k = LBound(FName) To UBound(FName)
|
| Open FName(k) For Input As FNum
| i = 1
| Do While Not InStr(1, sLine, "TheCell # 22", vbTextCompare) > 0
| Line Input #FNum, sLine
| i = i + 1
| Loop
|
| Debug.Print sLine
|
| For i = 1 To 300
| Line Input #FNum, sLine
| Next i
|
| Debug.Print sLine
|
| i = 1
| Do While Not InStr(1, sLine, "EndCell# 22", vbTextCompare) > 0
| Line Input #FNum, sLine
| s1data(i, 1) = Right(sLine, Len(sLine) - InStr(1, sLine, "
| "))
| s2data(i, 1) = Left(sLine, Len(sLine) - InStr(1, sLine, "
| "))
| i = i + 1
| Loop
|
|
| Close FNum
|
| 'START_Write output
| i = i - 2
| ActiveWorkbook.Sheets(1).Activate
| For j = 1 To i
| Cells(j , 1).Value = s1data(j, 1)
| Cells(j , 2).Value = s2data(j, 1)
| Next j
|
| End Sub
| ##########################################################################
|
 

Top