need some help for linear interpolation

[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
##########################################################################

 

[Tom Ogilvy]

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