I'm trying to use this VBA code to price American or European options... But I run into
"Compile error: Can't find project or library"
with dt =T/n highlighted.
I can't determine what is wrong. Hoping someone smarter than I can point out what I'm overlooking.
Function CRRTree(Spot, K, T, rf, vol, n, OpType As String, ExType As String)
dt = T / n
u = Exp(vol * (dt ^ 0.5))
d = 1 / u
p = (Exp(rf * dt) - d) / (u - d)
' Tree for stock price
Dim S() As Double
ReDim S(n + 1, n + 1) As Double
For i = 1 To n + 1
For j = i To n + 1
S(i, j) = Spot * u ^ (j - i) * d ^ (i - 1)
Next j
Next i
' Calculate Terminal Price for Calls and Puts
Dim Op() As Double
ReDim Op(n + 1, n + 1) As Double
For i = 1 To n + 1
Select Case OpType
Case "C": Op(i, n + 1) = Application.Max(S(i, n + 1) - K, 0)
Case "P": Op(i, n + 1) = Application.Max(K - S(i, n + 1), 0)
End Select
Next i
' Calculate Remaining entries for Calls and Puts
For j = n To 1 Step -1
For i = 1 To j
Select Case ExType
Case "A":
If OpType = "C" Then
Op(i, j) = Application.Max(S(i, j) - K, Exp(-rf * dt) * (p * Op(i, j + 1) + (1 - p) * Op(i + 1, j + 1)))
ElseIf OpType = "P" Then
Op(i, j) = Application.Max(K - S(i, j), Exp(-rf * dt) * (p * Op(i, j + 1) + (1 - p) * Op(i + 1, j + 1)))
End If
Case "E":
Op(i, j) = Exp(-rf * dt) * (p * Op(i, j + 1) + (1 - p) * Op(i + 1, j + 1))
End Select
Next i
Next j
CRRTree = Op(1, 1)
End Function
Related
I have been reading on some of the posts that others were having similar issues for comparing text strings in cells.
The results were close but not quite what the goal is so I a confident that I will get the results.
The image attached is just the desired result. Goal: Compare Old SQL (Column B) to New SQL(Column A)/change font color of the difference in Column A (if any).
image attached shows the desired result
Being 20 yrs removed, I am beyond rusty.
I have tried the leverstein (?? sorry forget the author); tried dupeword and a couple others. Just havent found the right code. I am going to keep looking at examples - I am sure someone has figured it out - just not me.
Public Sub AlignStrings()
Dim a() As Byte, b() As Byte, a_$, b_$, i&, j&, d&, u&, l&, x&, y&, f&()
Const GAP = -1
Const PAD = "$"
a = [a3].Text: b = [b3].Text 'column A &B needs to be a range
'[c2:d2].Clear
'[a1:a6].Font.Name = "Calibri"
ReDim f(0 To UBound(b) \ 2 + 1, 0 To UBound(a) \ 2 + 1)
For i = 1 To UBound(f, 1)
For j = 1 To UBound(f, 2)
x = j - 1: y = i - 1
If a(x * 2) = b(y * 2) Then
d = 1 + f(y, x)
u = 0 + f(y, j)
l = 0 + f(i, x)
Else
d = -1 + f(y, x)
u = GAP + f(y, j)
l = GAP + f(i, x)
End If
f(i, j) = Max(d, u, l)
Next
Next
i = UBound(f, 1): j = UBound(f, 2)
On Error Resume Next
Do
x = j - 1: y = i - 1
d = f(y, x)
u = f(y, j)
l = f(i, x)
Select Case True
Case Err
If y < 0 Then GoTo left Else GoTo up
Case d >= u And d >= l Or Mid$(a, j, 1) = Mid$(b, i, 1)
diag:
a_ = Mid$(a, j, 1) & a_
b_ = Mid$(b, i, 1) & b_
i = i - 1: j = j - 1
Case u > l
up:
a_ = PAD & a_
b_ = Mid$(b, i, 1) & b_
i = i - 1
Case l > u
left:
a_ = Mid$(a, j, 1) & a_
b_ = PAD & b_
j = j - 1
End Select
Loop Until i < 1 And j < 1
DecorateStrings a_, b_, [a3], [b3], PAD 'output needs to be in same
columns/range
I'm trying to get my VBA code to output a graph in excel based on an inputted range that was selected using a user defined function from multiple cells. I've passed the data to the sub as a range but it ends up assuming that the range is two data sets rather than one data set with x and y values. The data set is selected from excel into a function that is being written separately which then calls the sub.
Sub CreateChart(ByRef r As Range)
Dim cht As Object
Set cht = ActiveSheet.Shapes.AddChart2
cht.Chart.SetSourceData Source:=r
cht.Chart.ChartType = xlXYScatterLines
End Sub
I called the sub through
Call CreateChart(r)
with r being a two column range of data that was selected from excel.
Public Function cubic(ByVal r As Range, x As Double, Optional check As Integer = 1) As Double
The overall function code is here as well
Public Function cubic(ByVal r As Range, x As Double, Optional check As Integer = 1) As Double
Dim data() As Double
Dim check1 As Integer
Dim Smatrix() As Double
Dim Tmatrix() As Double
Dim Xmatrix() As Double
Dim Amatrix() As Double
Dim Hmatrix() As Double
Dim m As Integer
Dim i As Integer
m = r.Rows.Count
ReDim data(1 To m, 2)
ReDim Smatrix(1 To m, 1 To m)
ReDim Tmatrix(1 To m, 4)
ReDim Xmatrix(1 To m)
ReDim Amatrix(1 To m - 1, 1 To 4)
ReDim Hmatrix(1 To m)
check1 = Test(check)
For i = 1 To m
data(i, 1) = r(i, 1).Value
data(i, 2) = r(i, 2).Value
Next i
Smatrix(1, 1) = 1
Smatrix(m, m) = 1
For i = 1 To m - 1
Hmatrix(i) = data(i + 1, 1) - data(i, 1)
Next i
If check1 = 2 Then
Smatrix(1, 2) = -1
Smatrix(m, m - 1) = -1
End If
For i = 2 To m - 1
Smatrix(i, i - 1) = Hmatrix(i - 1)
Smatrix(i, i + 1) = Hmatrix(i)
Smatrix(i, i) = 2 * (Hmatrix(i - 1) + Hmatrix(i))
Next i
For i = 2 To m - 1
Tmatrix(i, 4) = 6 * ((data(i + 1, 2) - data(i, 2)) / Hmatrix(i) - (data(i, 2) - data(i - 1, 2)) / Hmatrix(i - 1))
Next i
For i = 1 To m
If i <> 1 Then
Tmatrix(i, 1) = Smatrix(i, i - 1)
End If
Tmatrix(i, 2) = Smatrix(i, i)
If i <> m Then
Tmatrix(i, 3) = Smatrix(i, i + 1)
End If
Next i
For i = 2 To m
Tmatrix(i, 1) = Tmatrix(i, 1) / Tmatrix(i - 1, 2)
Tmatrix(i, 2) = Tmatrix(i, 2) - Tmatrix(i, 1) * Tmatrix(i - 1, 3)
Tmatrix(i, 4) = Tmatrix(i, 4) - Tmatrix(i, 1) * Tmatrix(i - 1, 4)
Next i
Xmatrix(m) = Tmatrix(m, 4) / Tmatrix(m, 2)
For i = m - 1 To 1 Step -1
Xmatrix(i) = (Tmatrix(i, 4) - Tmatrix(i, 3) * Xmatrix(i + 1)) / Tmatrix(i, 2)
Next i
For i = 1 To m - 1
Amatrix(i, 1) = (Xmatrix(i + 1) - Xmatrix(i)) / 6 * Hmatrix(i)
Amatrix(i, 2) = Xmatrix(i) / 2
Amatrix(i, 3) = (data(i + 1, 2) - data(i, 2)) / Hmatrix(i) - Hmatrix(i) * Xmatrix(i) / 2 - Hmatrix(i) * (Xmatrix(i + 1) - Xmatrix(i)) / 6
Amatrix(i, 4) = data(i, 2)
Next i
If x < data(1, 1) Or x > data(m, 1) Then
Call Check2(x)
If x < data(1, 1) Then
cubic = Amatrix(1, 1) * (x - data(1, 1)) ^ 3 + Amatrix(1, 2) * (x - data(1, 1)) ^ 2 + Amatrix(1, 3) * (x - data(1, 1)) + Amatrix(1, 4)
ElseIf x > data(m, 1) Then
cubic = Amatrix(m - 1, 1) * (x - data(m - 1, 1)) ^ 3 + Amatrix(m - 1, 2) * (x - data(m - 1, 1)) ^ 2 + Amatrix(m - 1, 3) * (x - data(m - 1, 1)) + Amatrix(m - 1, 4)
End If
ElseIf x = data(m, 1) Then
cubic = data(m, 2)
Else
For i = 1 To m - 1
If data(i, 1) < x And x < data(i + 1, 1) Then
cubic = Amatrix(i, 1) * (x - data(i, 1)) ^ 3 + Amatrix(i, 2) * (x - data(i, 1)) ^ 2 + Amatrix(i, 3) * (x - data(i, 1)) + Amatrix(i, 4)
ElseIf x = data(i, 1) Then
cubic = data(i, 2)
End If
Next i
End If
Call CreateChart(r)
End Function
As well as the subroutine and function called within the function that haven't been posted
Public Function Test(check As Integer) As Integer
Dim Response As Integer
If check = 1 Then
Response = MsgBox("Boundary Condition 1 selected, is this correct (select No for boundary condition 2)?", vbYesNo, "Boundary Conditions")
If Response = 6 Then
Test = 1
Else
Test = 2
End If
ElseIf check = 2 Then
Response = MsgBox("Boundary Condition 2 selected, is this correct (select No for boundary condition 1)?", vbYesNo, "Boundary Conditions")
If Response = 6 Then
Test = 2
Else
Test = 1
End If
Else
Response = MsgBox("Incorrect Boundary Condition, select Yes for condition 1 and No for condition 2", vbYesNo, "Boundary Conditions")
If Response = 6 Then
Test = 1
Else
Test = 2
End If
End If
End Function
Public Sub Check2(x)
MsgBox ("Value given is outside data range, answer may not be correct, extrapolating from calculated polynomial")
End Sub
Try
Sub CreateChart(ByRef r As Range)
Dim cht As Object
Set cht = ActiveSheet.Shapes.AddChart2(XlChartType:=xlXYScatterSmooth)
cht.Chart.SetSourceData Source:=r
End Sub
I have written a code which solves a system of linear equations serval times in a row during a Monte Carlo simulation.
For each run the input is slightly changed and the solution must be calculated every time again. The purpose of this is to obtain the probability distribution function of the results (the solutions of the linear system).
So, my question is:
Is there a way to solve the system of linear equations only once and save the generic solution so that for every Monte Carlo run the solutions can be calculated directly?
This would be very time saving as for a proper simulation I need at least 20k runs and even for small systems of three unknowns this takes a long time. My code solves this linear equations every time new as in its original version the number of variables and therefore the number of input quantities should be closable and thus the generic solutions are unknow.
Here is my Gaussian elimination algorithm.
Function gaussian_elimination(w As Variant, mm As Variant, R As Variant, rb As Variant, n_iso As Integer) As Variant()
'initializing running indexes
Dim i As Integer
Dim j As Integer
Dim h As Integer
Dim n As Integer
n = n_iso
'runing variables for Gauss elimination
Dim ip As Integer
Dim q As Integer
Dim p As Integer
Dim z As Double
Dim temp1(1, 1) As Variant
Dim temp2(1, 1) As Variant
Dim sum As Variant
'initializing b vector
Dim b() As Variant
ReDim b(1 To n - 1, 0 To 1)
'initializing k vector
Dim k() As Variant
ReDim k(1 To n - 1, 0 To 1)
'initializing A matrix
Dim a() As Variant
ReDim a(1 To n - 1, 1 To n - 1)
'initializing X matrix
Dim x() As Variant
ReDim x(1 To n - 1, 1 To n)
' calculating b vector
For i = 1 To (n - 1) Step 1
b(i, 0) = mm(1, 0) / (w(i + n - 1, 0) * (rb(i, 0) - R(i * n, 0))) - mm(1, 0) / (w(i, 0) * (R(i, 0) - rb(i, 0)))
Next i
'calculating A matrix
For i = 1 To (n - 1) Step 1
For j = 1 To (n - 1) Step 1
a(i, j) = mm(j + 1, 0) * ((R(j + i * (n - 1), 0) / (w(i + n - 1, 0) * (rb(i, 0) - R(i * n, 0)))) - (R(j, 0) / (w(i, 0) * (R(i, 0) - rb(i, 0)))))
Next j
Next i
'using on board solving routine
Dim A_Inv As Variant
Dim k_vec As Variant
Dim b_dummy As Variant
'filling X matrix
For i = 1 To n - 1 Step 1
For j = 1 To n Step 1
If j = (n) Then
x(i, j) = b(i, 0)
Else: x(i, j) = a(i, j)
End If
Next j
Next i
'Gaussian elimination
For i = 1 To (n - 2) Step 1
For j = i + 1 To (n - 1) Step 1
If (Abs(x(j, i)) > Abs(x(i, i))) Then
For h = 1 To n
temp1(1, 1) = x(i, h)
temp2(1, 1) = x(j, h)
x(i, h) = temp2(1, 1)
x(j, h) = temp1(1, 1)
Next h
End If
Next
For p = i + 1 To n - 1
z = x(p, i) / x(i, i)
For q = i + 1 To n
x(p, q) = x(p, q) - z * x(i, q)
Next q
x(p, i) = 0
Next p
Next i
'calculatiing k factors backwards
If Abs(x(UBound(x, 1), UBound(x, 2) - 1)) <= 0 Then
MsgBox "Equation system can not be solved! Solving for k factors faild", vbExclamation, "Warning!"
Exit Function
End If
k((UBound(x, 1)), 0) = x((UBound(x, 1)), UBound(x, 2)) / x((UBound(x, 1)), (UBound(x, 2) - 1))
For i = ((UBound(x, 1) - 1)) To (LBound(x, 1)) Step -1
sum = x(i, UBound(x, 2))
For j = i + 1 To (UBound(x, 2) - 1) Step 1
sum = sum - x(i, j) * k(j, 0)
Next j
k(i, 0) = sum / x(i, i)
Next i
For i = 1 To n - 1
k(i, 0) = (-1) * k(i, 0)
Next i
gaussian_elimination = k
End Function
My code is designed to test each agent (turtle) with its respective agent (ninjaturtle). It checks for three parameters. However, I keep getting an overflow error. I have converted my d1 and d2 to Long, Int, Variant, but I still keep getting the error. I even tried using cLng, cdbl, etc. but still nothing. The error is found on d2 with the value of 330.552970855757.
The error is thrown in the d2 = ((Cells(amount * (time - 1) + ninjaturtle + 1, 1).Value)) statement.
Sub assesser()
Dim time As Integer
Dim turtle As Integer
Dim ninjaturtle As Integer
Dim amount As Integer
Dim d1 As Variant
Dim d2 As Variant
amount = 20
Columns(15).Clear
Cells(1, 15).Value = "Flock"
For time = 1000 To 2000
For turtle = 1 To 20
For ninjaturtle = 1 To 20
d1 = (Cells(amount * (time - 1) + turtle + 1, 1).Value)
d2 = ((Cells(amount * (time - 1) + ninjaturtle + 1, 1).Value))
If (Abs(d1 - d2) < 15 _
Or Abs(d1 - d2) > 345) _
And Abs(d1 - d2) < 10 _
And Abs(d1 - d2) < 10 _
Then If IsEmpty(Cells(amount * (time - 1) + turtle + 1, 15).Value) = True Then Cells(amount * (time - 1) + turtle + 1, 15).Value = CStr(Cells(amount * (time - 1) + turtle + 1, 15)) + " " + CStr(Cells(amount * (time - 1) + ninjaturtle + 1, 5)) _
Else Cells(amount * (time - 1) + turtle + 1, 15).Value = CStr(Cells(amount * (time - 1) + turtle + 1, 15)) + ", " + CStr(Cells(amount * (time - 1) + ninjaturtle + 1, 5))
Next ninjaturtle
Next turtle
Next time
Debug.Print (d1)
Debug.Print (d2)
End Sub
How do i decode %C3%B8 in VBA? it is the danish letter ΓΈ -
It is encoded in UTF-8. I have tried to decode it in vba for use in a excel sppreadsheet with the following function:
Function DecodeUTF8(s)
Dim i
Dim c
Dim n
i = 1
Do While i <= Len(s)
c = Asc(Mid(s, i, 1))
If c And &H80 Then
n = 1
Do While i + n < Len(s)
If (Asc(Mid(s, i + n, 1)) And &HC0) <> &H80 Then
Exit Do
End If
n = n + 1
Loop
If n = 2 And ((c And &HE0) = &HC0) Then
c = Asc(Mid(s, i + 1, 1)) + &H40 * (c And &H1)
Else
c = 191
End If
s = Left(s, i - 1) + Chr(c) + Mid(s, i + n)
End If
i = i + 1
Loop
DecodeUTF8 = s
End Function
You have to use UrlDecode or HmlDecode methods
see here for more information
http://msdn.microsoft.com/en-us/library/system.web.httputility.urldecode.aspx
or here
http://msdn.microsoft.com/en-us/library/7c5fyk1k.aspx