I'm working on a function to do linear interpolation:
Public Function linear_interpolation(xs As Range, ys As Range, x As Double)
Dim index As Integer
Dim x0 As Double, x1 As Double
Dim y0 As Double, y1 As Double
index = Application.WorksheetFunction.Match(x, xs)
x0 = xs(index)
y0 = ys(index)
x1 = xs(index + 1)
y1 = ys(index + 1)
linear_interpolation = ((x1 - x) * y0 + (x - x0) * y1) / (x1 - x0)
End Function
It works fine if both ranges xs and ys are fully populated, but if there is a missing value (empty cell) then it is treated as a zero, which is surprising, I was expecting a type error. If the cell contains a non-numerical value, then I get #VALUE! as expected.
What's the best way of dealing with this? Do I have to manually check to see if xs(index), ys(index), xs(index+1) and ys(index+1) empty and then return an error?
If you still need 0 in the cell but wan to flag error for NULL or "" you could easily involve a check that says
IF cell.value = VBNullString Then
'do some stuff
End If
No sense reinventing the wheel! There's a linear interpolation function on my website - I apologize for the shameless plug - that grabs the nearest values to the value you're trying to interpolate on so you don't have to worry about the empty cells registering as zeros:)
Bottom line is you want to add a check for the values equal to an empty string ""
Source: http://wellsr.com/vba/2016/excel/powerful-excel-linear-interpolation-function-vba/
Related
I am trying to create a Sankey-diagram in Excel, and as a start to this, I am trying to create some "entry arrows" for the left part of the diagram, which will look roughly like this:
I created it by making a chevron arrow, and dragging the rightmost points of it to line up with the tip of the arrow.
Now, to do this for all the arrows I need, I want to do this programmatically, but I can't figure out if there is any way to do much with the nodes (?) of the shape. Trying to record a macro gave me nothing.
This is what I have so far, the macro aborts on the Debug.Print line, probably because the node object doesn't have a Left property :P
Sub energiInn()
Dim r As Range, c As Range
Dim lo As ListObject
Dim topp As Double, høgde As Double
Dim i As Long, farge As Long
Dim nd As Object
Set lo = Tabell.ListObjects("Energi_inn_elektrolyse")
Set r = lo.DataBodyRange
topp = 50
With SankeyDiagram.Shapes
For i = 1 To r.Rows.Count
høgde = Application.WorksheetFunction.Max(10, r.Cells(i, 2) / 50#)
With .AddShape(Type:=msoShapeChevron, Left:=50, top:=topp, Width:=200, Height:=høgde)
.Name = r.Cells(i, 1)
farge = fargekart((i - 1) Mod UBound(fargekart))
.Fill.ForeColor.RGB = RGB(farge Mod 256, (farge \ 256) Mod 256, farge \ 65536)
For Each nd In .Nodes
Debug.Print nd.Left
Next nd
End With
topp = topp + høgde
Next i
End With
Debug.Print r.Address
End Sub
Honestly, I am unsure if this can be done at all, but even if it is impossible, it would be nice to get it confirmed :)
What you're looking for is .Nodes.SetPosition. Because it's relative positioning, this can be a challenge. You need to use the objects position elements to make sure the points are moving in relation to the shape.
With .AddShape(Type:=msoShapeChevron, Left:=50, Top:=topp, Width:=200, Height:=høgde)
.Name = r.Cells(i, 1)
.Nodes.SetPosition 2, .Left + .Width, .Top
.Nodes.SetPosition 4, .Left + .Width, .Top + .Height
First argument is the node index. Next is the x position, which we want all the way to the right of the graphic, so we add the shapes position left to the width of the shape. Last is the y position, first point we want in the topmost corner, so we use the shapes top. Last point, we add the height to the top position to bring to the bottom corner.
I believe it would be more simple drawing this as free form using Shapes.BuildFreeform Method and then converting to shape using FreeformBuilder.ConvertToShape Method.
Example:
Sub drawEntryArrow()
Dim x1 As Single, y1 As Single, w As Single, h As Single
Dim oShape As Shape
x1 = 10
y1 = 10
w = 200
h = 200
With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, x1, y1)
.AddNodes msoSegmentLine, msoEditingAuto, x1 + w, y1
.AddNodes msoSegmentLine, msoEditingAuto, x1 + w, y1 + h
.AddNodes msoSegmentLine, msoEditingAuto, x1, y1 + h
.AddNodes msoSegmentLine, msoEditingAuto, x1 + w / 2, y1 + h / 2
.AddNodes msoSegmentLine, msoEditingAuto, x1, y1
Set oShape = .ConvertToShape
End With
End Sub
If you just want to get rid of the point at the right, you can simply delete the node (nodes of a chevron are counted clockwise starting at the top left):
.Nodes.Delete 3
To get access to all nodes with the nodes-property of a shape, however, as long as you deal with a standard shape type, you can't access the coordinates.
When you use the "edit points", a shape changes its type to msoShapeNotPrimitive - but I couldn't figure out how to do this using VBA.
UPDATE
Played around a bit (because I'm curious) - just as an example if someone wants to change a shape manually:
' First change Shape Type:
' WILL NOT WORK: sh.AutoShapeType = msoShapeNotPrimitive
' Instead, add a node and remove it immediately. This changes the shape type.
.Nodes.Insert c, msoSegmentLine, msoEditingCorner, 100, 100
.Nodes.Delete c + 1
' Now access the x-coordinate of node 2 and the y-coordinate of node 3
' (note that we cannot access the coordinates directly)
Dim pointsArray() As Single, x As Single, y As Single
pointsArray = .Nodes(2).Points
x = pointsArray(1, 1)
pointsArray = .Nodes(3).Points
y = pointsArray(1, 2)
' Now change the x-value of node 3
sh.Nodes.SetPosition 3, x, y
I'm trying to figure out how to code a straight line to the straight part of a curve, the curve should look something like the exponential, click the link to open the image:
Straight line to Curve and determining the x-intercept
Here is the code, I'm only using the exponential as an example
`
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
Dim s As String
Dim xl As New Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
wb = xl.Workbooks.Add 'create new workbook
ws = wb.Worksheets(1) 'select sheet 1
ws.Activate()
Dim Currents() As Double
Dim PhotodiodeValues() As Double
Dim AppliedCurrent As Double
'AppliedCurrent = SerialPort1.ReadLine
AppliedCurrent = 0
If AppliedCurrent >= 0 And AppliedCurrent < 0.1 Then
Dim j As Integer = 1
For i As Double = 0 To 5 Step 0.5
ReDim Preserve Currents(j)
ReDim Preserve PhotodiodeValues(j)
MsgBox(i)
MsgBox("LDI " & CType(i, String))
s = ("LDI " & CType(i, String))
AppliedCurrent = i
If AppliedCurrent >= i And AppliedCurrent < (i + 0.1) Then
Currents(j) = CType(i, Double)
Label1.Text = Currents(j)
PhotodiodeValues(j) = CType(Math.E ^ (i), Double)
ws.Cells(j, 1) = Currents(j)
ws.Cells(j, 2) = PhotodiodeValues(j)
Else
System.Threading.Thread.Sleep(1000)
End If
j = j + 1
Next
Else
System.Threading.Thread.Sleep(1000)
End If
sfd1.ShowDialog() 'get file name
wb.SaveAs(sfd1.FileName) 'save data to file
wb.Close()
xl = Nothing 'dispose of excel
ScatterGraph1.PlotXY(Currents, PhotodiodeValues)
'SerialPort1.Close()
End Sub
End Class`
First off, I'll explain my thought process. If I have misunderstood, please let me know and I will update my answer. The slope dy/dx of the curve y = e^x is dy/dx = e^x, a monotonically increasing function of x for all real x. There is never a point at which the function becomes linear and, while it has a horizontal asymptote (y = 0) it has no vertical asymptote.
I take it that what you want is the equation of a tangent line taken at a point where the slope first becomes greater than some cutoff value m*. After that point, the graph of y = e^x "might as well" be a straight line for your intents and purposes.
So, we must first solve the equation m* = dy/dx = e^x for the x at which m* occurs. The range of e^x is all positive real numbers and e^x is monotonically increasing, so any positive real number m* will have a unique solution x*. indeed, x* = ln(m*). Our tangent line will pass through the point (x*, e^x*) and have slope m*. Recall that m* = e^x*, so the point is (ln(m*), m*) and the slope is m*.
With a point and the slope, we can figure out the equation of a line. We have that the slope from the given point to any other point must be m*; so, (y - y*)/(x - x*) = m*. Rearranging, (y - y*) = m*(x - x*), y = mx - mx* + y*, and finally y = mx + (y - mx) = mx + (m - mln(m)). The Y-intercept is therefore (m* - mln(m)). We can get the X-intercept by setting y = 0 and solving for x: 0 = mx + (m - mln(m)), mx = mln(m*) - m*, x = ln(m*) - 1.
In summary:
the equation of the line tangent to y = e^x with slope m* is y = mx + (m - mln(m)).
the Y-intercept of this line is (m* - mln(m)).
the X-intercept of this line is ln(m*) - 1
If the curve is known at compile time, I recommend hard-coding a closed form analytical solution for the derivative and any asymptotes. If the function is not known until runtime, the derivative at a given point can be approximated numerically using a variety of methods. Intuitively, the definition of the derivative as the limit of (f(x+d) - f(x)) / d as d approaches zero can be used to find approximations of the derivative where the derivative (likely) exists. For well-behaved analytic functions, you will typically be safe except in special cases.
If the function's derivative is monotonically non-decreasing, as in this example, you can find the point (if any) at which the function's slope meets or exceeds a certain cutoff using approximation (as above) in conjunction with something akin to binary search. Start at a value such as x = 0, and increase or decrease x by some multiplicatively increasing factor until you have passed your target. Now, with bounds on the values of x between which your target can be found, check the middle of the range, and then either the left or right half recursively until a suitably good x* is found.
I need to use Newton's method on closures.
Function f (x as Double, y as Double) as Double
f = x^3-y
End Function
I get the value of y from a cell and then I would like to find out when f is zero. In the toy example above, if the cell contains y=8, then I would expect Newton's method to find a solution close to x=2.
My solution was to make a newton_solve_f function:
Function newton_solve_f (y as Double as Double) as Double
Dim x as Double
x = 0 'initial guess for x
'do Newton's method to find x
...
newton_solve_f = x
End Function
so in effect, I copy paste my code for Newton's method (taken from here) into newton_solve_f.
The problem is that I have several such fs (some with more than two arguments), and it would be really neat if I didn't have to make a separate almost identical newton_solve_f for every one of them.
How would you solve this in VBA?
In Python, for example, it's possible to solve this problem as follows:
def f(y):
def g(x):
return x^3-y
return g
def newton_solve(f):
#do newton's method on f(x)
newton_solve(f(3))
Here f(3) is a function, a closure of one variable. (The closure example on wikipedia is almost identical to this one.)
ps. I know Newton's method also needs the (partial) derivative of f, I'm actually doing something that's more like the secant method, but that's irrelevant for what I'm asking about
Closures are not part of VBA. But you can use static variables within a method scope. They cannot be used outside the method. If you want a variable to visible outside, then you have to use global variable. Preferable declare it public in a module.
We cannot define function inside function in VB. Tried to convert the code given in the link you have mentioned. I hope it helps you. Not well versed with php, but you can see the approach below and make changes accordingly.
Sub Test()
Dim x As Double
Dim y As Double
Dim z As Double
x = Cells(1, 1).Value
y = Cells(1, 2).Value
z = NewtRap("Fun1", "dFun1", x, y)
Cells(1, 3).Value = z
End Sub
Private Function NewtRap(fname As String, dfname As String, x_guess As Double, y_value As Double) As Double
Dim cur_x As Double
Dim Maxiter As Double
Dim Eps As Double
Maxiter = 500
Eps = 0.00001
cur_x = x_guess
For i = 1 To Maxiter
If (fname = "Fun1") Then
fx = Fun1(cur_x)
ElseIf (fname = "dFun1") Then
fx = dFun1(cur_x)
ElseIf (fname = "f") Then
fx = f(cur_x, y_value)
End If
If (dfname = "Fun1") Then
fx = Fun1(cur_x)
ElseIf (dfname = "dFun1") Then
fx = dFun1(cur_x)
ElseIf (dfname = "f") Then
fx = f(cur_x, y_value)
End If
If (Abs(dx) < Eps) Then Exit For
cur_x = cur_x - (fx / dx)
Next i
NewtRap = cur_x
End Function
Function f(x As Double, y As Double) As Double
f = x ^ 3 - y
End Function
Function Fun1(x As Double) As Double
Fun1 = x ^ 2 - 7 * x + 10
End Function
Function dFun1(x As Double) As Double
dFun1 = 2 * x - 7
End Function
So to first summarise: You want to create a function that will find (using Newton-Raphson method) the roots of a function. You already have this written and working for certain functions but would like help expanding your code so it will work with a variety of functions with varying numbers of parameters?
I think you first need to think about what input functions you want it to cover. If you are only dealing with polynomials (as your example suggests), this should be fairly straightforward.
You could have general functions of:
Function fnGeneralCase (x, y, z, w, a1, a2, a3, b1, b2, b3, c1, c2, c3 as Double) as Double
fnGeneralCase = a1*x^3 + a2*x^2 + a3*x + b1*y^3 + b2*y^2 + b3*y + c1*z^3 + c2*z^2 + c3*z + w
End Function
Function fnDerivGeneralCase (x, y, z, w, a1, a2, a3, b1, b2, b3, c1, c2, c3 as Double) as Double
fnDerivGeneralCase = a1*3*x^2 + a2*2*x + a3 + b1*3*y^2 + b2*2*y + b3 + c1*3*z^2 + c2*2*z + c3
End Function
And just set the inputs to zero when you don't need them (which will be for the majority of the time).
So for your example calling:
answer = fnGeneralCase(guess, 0, 0, -8, 1, 0, 0, 0, 0, 0, 0, 0, 0)
basically gives:
function = x^3-8
If you want to include more than polynomials, this will get more complicated but you could still use the above approach...
This seems to be asking 2 related questions:
how to pass a function as an argument in vba.
how to create a closure out of an existing function.
Unfortunately neither of these are really supported, however,
for 1 you can generally work around this by passing a string function name and using 'Application.Run' to invoke the function.
2 is trickier if you have lots of functions with different numbers of parameters, but for a set number of parameters you could add extra parameters to the newton_solve function or maybe use global variables.
e.g.
Public Function f(x as Double, y as Double) as Double
f = x^3-y
End Function
Function newton_solve_f (function_name as String, y as Double) as Double
Dim x as Double
x = 0 'initial guess for x
'do Newton's method to find x
...
' invoke function_name
x = Application.Run(function_name, x, y)
...
newton_solve_f = x
End Function
Assuming f is in a module called 'Module1' you can call this with:
x = newton_solve('Module1.f', 3)
Note that the function you want to call must be public.
I was creating a critical value approximator of American style options. I was getting the error "#Value!" only after around 40 loops (kept track with a counter).
After some trial and error I realized it came from the part of the loop calling the BlackScholes pricing function. In theory I want to run through a range of values iteratively for the spot price while keeping the other variables fixed in a Black Scholes European price calculation. After tinkering around I reduced the issue to the fact that after the first loop it was no longer calculating Black Scholes the way it would if I just used the value on that iteration and the value I was getting was just increasing by 1, then crapping out after 40 loops of wrong values for some non obvious reason.
So below I truncated the code to a very simple skeleton which is the essence of my problem. Any help would be appreciated.
Function Looper(S As Double, K As Double, r As Double, t As Double, q As Double, Vol As Double) As Double
Dim i As Double
For i = 100 To 150 Step 1#
MsgBox i
MsgBox BS(i, K, r, t, q, Vol, "Call") 'After the first loop the values are wrong,
'What I'd like is, BS(100,...), BS(101,...),BS(102,...) which it is not.
'Not sure what it's actually calculating, since the values are way off
Next i
End Function
Public Function BS(S As Double, K As Double, r As Double, t As Double, q As Double, Vol As Double, CP As String) As Double
Dim volrootime As Double
Dim d1 As Double
Dim d2 As Double
Dim DiscF As Double
Dim DivF As Double
Dim topline1 As Double
Dim topline2 As Double
Dim topline As Double
Dim Price As Double
t = t / 365
r = r / 100
q = q / 100
DiscF = Exp(-r * t)
DivF = Exp(-q * t)
volrootime = (t ^ 0.5) * Vol
topline1 = Log(S / K)
topline2 = ((r - q) + ((Vol ^ 2) / 2)) * t
topline = topline1 + topline2
d1 = topline / volrootime
d2 = d1 - volrootime
If CP = "Call" Then
' Theta is in terms of Calendar days, changing the denominator to 252 changes it to trading days
Price = (S * DivF * Bign(d1)) - (K * DiscF * Bign(d2))
Else
' Theta is in terms of Calendar days, changing the denominator to 252 changes it to trading days
Price = K * DiscF * Bign(-d2) - S * DivF * Bign(-d1)
End If
BS = Price
End Function
The values of r, t, q change each time the BS function is called. If they must stay constant, you should use ByVal in the BS function declaration like this:
BS(S As Double, K As Double, ByVal r As Double, ByVal t As Double, ByVal q As Double, ...
By default, the parameters are passed by reference and any change in the called function are reflected in the calling function.
By the way, in this example, I wouldn't use messageboxes when debugging but instead use debug.print like this:
Debug.Print "i=" & i & vbTab & "BS=" & BS(i, K, r, t, q, Vol, "Call")
The print is made in the window opened by pressing Ctl + G (Go To).
I want to get the angle of two points on a Line chart.
I know how to calculate an angle, the problem is that I need the x and y of the seriescollection.point and I have no idea how to get it.
Can someone help me with it?
EDIT:
Jean-François Corbett showed me how to get the points, I meant from top and left, and not point on the graph (on X scale and Y scale) though it can work.
I calculate it wrong. how can I calculate the angles in the picture below?
You ask how to get the (x,y) coordinates of points in a chart series. Here is how:
Dim c As Chart
Dim s As Series
Dim x As Variant
Dim y As Variant
Set c = ActiveChart
Set s = c.SeriesCollection.Item(1)
x = s.XValues
y = s.Values
EDIT As far as I can tell from the edited question, OP now wants the pixel coordinates of each point, with origin at the top left of the plot. To do so, you just need to scale by the axis width and span. The x axis is a bit tricky in the case of line plots (which I hate), because there is no min or max scale property; have to use the number of "categories" instead. The following code does this scaling:
Dim c As Chart
Dim s As Series
Dim xa As Axis
Dim ya As Axis
Dim x As Variant
Dim y As Variant
Dim i As Long
Set c = ActiveChart
Set s = c.SeriesCollection.Item(1)
Set xa = c.Axes(xlCategory)
Set ya = c.Axes(xlValue)
x = s.XValues
y = s.Values
For i = LBound(x) To UBound(x)
' Scale x by number of categories, equal to UBound(x) - LBound(x) + 1
x(i) = (i - LBound(x) + 0.5) / (UBound(x) - LBound(x) + 1) * xa.Width
' Scale y by axis span
y(i) = ya.Height - y(i) / (ya.MaximumScale - ya.MinimumScale) * ya.Height
Next i
Note that y increases along the negative y direction on the plot, since you want the origin to be at the top left.
Using this x and y, you can calculate your angle as seen on the screen.
The X and Y values are not directly accessible from the Point object, (as best as I can tell), but they represent actual values passed to the graph. Try accessing them from the worksheet where they are stored.
If that is unavailable, try Series.values, which returns an array of Y-values, and Series.XValues, which returns an array of X-values. (See MSDN Reference)