Function BSOptionValue(iopt, s, k, v, d, r, t)

Dim edt, ert, d1, d2

edt = Exp(-d * t)
ert = Exp(-r * t)
If s > 0 And k > 0 And v > 0 And d > 0 And r > 0 And t > 0 Then

d1 = (Log(s / k) + (r - d + 0.5 * v * v) * t) / (v * Sqr(t))

d2 = d1 - v * Sqr(t)

BSOptionValue = iopt * (s * edt * Application.NormSDist(iopt * d1) - k * ert *

Application.NormSDist(iopt * d2))

Else

MsgBox ("Wrong Input")

BSOptionValue = -1

End If

End Function

----------------------------------------------------------------------------------

Private Sub OptionButton1_Click()

s = Cells(4, 2)
k = Cells(5, 2)
r = Cells(6, 2)
d = Cells(7, 2)
t = Cells(8, 2)
v = Cells(9, 2)

For i = 7 To 16
 s = Cells(i, 14)
For j = 16 To 18

t = Cells(6, j)

If j = 16 Then
Cells(i, 15) = Application.Max(s - k, 0)
End If

Cells(i, j) = BSOptionValue(1, s, k, v, d, r, t)

Next j

Next i

Worksheets("Chart_Sub").ChartObjects.Delete
Range("N6:R16").Select
ActiveSheet.Shapes.AddChart2(227, xlLineMarkers).Select
ActiveChart.SetSourceData Source:=Range("Chart_Sub!$N$6:$R$16")
ActiveChart.FullSeriesCollection(1).Name = "=""T=0"""
ActiveChart.FullSeriesCollection(2).Name = "=""T=1"""
ActiveChart.FullSeriesCollection(3).Name = "=""T=2"""
ActiveChart.FullSeriesCollection(4).Name = "=""T=3"""
ActiveChart.Legend.Select
ActiveChart.Legend.Select
Selection.Position = xlRight

With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = "Call"
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "S"
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Payoff"
End With
End Sub
------------------------------------------------------------------------------------------------------------
Private Sub OptionButton2_Click()

s = Cells(4, 2)
k = Cells(5, 2)
r = Cells(6, 2)
d = Cells(7, 2)
t = Cells(8, 2)
v = Cells(9, 2)

For i = 7 To 16
s = Cells(i, 14)
For j = 16 To 18

t = Cells(6, j)

If j = 16 Then
Cells(i, 15) = Application.Max(k - s, 0)
End If

Cells(i, j) = BSOptionValue(-1, s, k, v, d, r, t)
Next j

Next i

Worksheets("Chart_Sub").ChartObjects.Delete
Range("N6:R16").Select
ActiveSheet.Shapes.AddChart2(227, xlLineMarkers).Select
ActiveChart.SetSourceData Source:=Range("Chart_Sub!$N$6:$R$16")
ActiveChart.FullSeriesCollection(1).Name = "=""T=0"""
ActiveChart.FullSeriesCollection(2).Name = "=""T=1"""
ActiveChart.FullSeriesCollection(3).Name = "=""T=2"""
ActiveChart.FullSeriesCollection(4).Name = "=""T=3"""
ActiveChart.Legend.Select
ActiveChart.Legend.Select
Selection.Position = xlRight
 With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = "Put"
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "S"
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Payoff"
End With

End Sub

Private Sub OptionButton1_Click()

s = Cells(4, 2)
k = Cells(5, 2)
x = Cells(6, 2)
r = Cells(7, 2)
d = Cells(8, 2)
t = Cells(9, 2)
v = Cells(10, 2)
 Dim edt, ert, d1, d2
edt = Exp(-d * t)
ert = Exp(-r * t)
If s > 0 And k > 0 And v > 0 And d > 0 And r > 0 And t > 0 Then

d1 = (Log(s / k) + (r - d + 0.5 * v * v) * t) / (v * Sqr(t))

d2 = d1 - v * Sqr(t)

Cells(8, 6) = x * ert * Application.NormSDist(d2)

Else

MsgBox ("Wrong Input")

Cells(8, 6) = -1

End If

End Sub

-------------------------------------------------------------------------------------------------
Private Sub OptionButton2_Click()

s = Cells(4, 2)
k = Cells(5, 2)
x = Cells(6, 2)
r = Cells(7, 2)
d = Cells(8, 2)
t = Cells(9, 2)
v = Cells(10, 2)

Dim edt, ert, d1, d2

edt = Exp(-d * t)
ert = Exp(-r * t)
If s > 0 And k > 0 And v > 0 And d > 0 And r > 0 And t > 0 Then

d1 = (Log(s / k) + (r - d + 0.5 * v * v) * t) / (v * Sqr(t))

d2 = d1 - v * Sqr(t)
 Cells(8, 6) = x * ert * Application.NormSDist(-d2)

Else

MsgBox ("Wrong Input")

Cells(8, 6) = -1

End If

End Sub

Private Sub OptionButton3_Click()

s = Cells(4, 2)
k = Cells(5, 2)
x = Cells(6, 2)
r = Cells(7, 2)
d = Cells(8, 2)
t = Cells(9, 2)
v = Cells(10, 2)

Dim edt, ert, d1, d2

edt = Exp(-d * t)
ert = Exp(-r * t)
If s > 0 And k > 0 And v > 0 And d > 0 And r > 0 And t > 0 Then

d1 = (Log(s / k) + (r - d + 0.5 * v * v) * t) / (v * Sqr(t))

d2 = d1 - v * Sqr(t)

Cells(8, 6) = s * edt * Application.NormSDist(d1)

Else

MsgBox ("Wrong Input")

Cells(8, 6) = -1

End If
End Sub

Private Sub OptionButton4_Click()

s = Cells(4, 2)
k = Cells(5, 2)
x = Cells(6, 2)
r = Cells(7, 2)
d = Cells(8, 2)
t = Cells(9, 2)
v = Cells(10, 2)

Dim edt, ert, d1, d2

edt = Exp(-d * t)
ert = Exp(-r * t)
If s > 0 And k > 0 And v > 0 And d > 0 And r > 0 And t > 0 Then

d1 = (Log(s / k) + (r - d + 0.5 * v * v) * t) / (v * Sqr(t))

d2 = d1 - v * Sqr(t)

Cells(8, 6) = s * edt * Application.NormSDist(-d1)

Else

MsgBox ("Wrong Input")

Cells(8, 6) = -1

End If

End Sub
Private Sub CommandButton1_Click()

Range(Cells(7, 8), Cells(1000, 1000)).ClearContents 'select range and clear

contents

s0 = Cells(3, 2)
r = Cells(4, 2)
T = Cells(5, 2)
v = Cells(6, 2)
n = Cells(7, 2)

delta_t = T / n
u = Exp(v * (T / n))
d=1/u
p = (Exp(r * delta_t) - d) / (u - d)

Cells(9, 2) = delta_t
Cells(10, 2) = u
Cells(11, 2) = d
 Cells(12, 2) = p

For i = 0 To n 'run time labels

Cells(7, 7 + i + 1) = i

Next i

Cells(8, 8) = s0 'initialize

For j = 1 To n 'run columns

For k = 0 To j 'run rows

If j > k Then
Cells(8 + k, 8 + j) = Cells(8 + k, 8 + j - 1) * u
End If

If j = k Then
Cells(8 + k, 8 + j) = Cells(8 + k - 1, 8 + j - 1) * d
End If

Next k
Next j

End Sub
 Private Sub CommandButton1_Click()

Range(Cells(7, 8), Cells(1000, 1000)).ClearContents 'select range and clear

contents

s0 = Cells(3, 2)
r = Cells(4, 2)
T = Cells(5, 2)
v = Cells(6, 2)
n = Cells(7, 2)
q = Cells(8, 2)
p = Cells(9, 2)

delta_t = T / n
u = Exp((r - q - 0.5 * v * v) * delta_t + v * Sqr(delta_t))
d = Exp((r - q - 0.5 * v * v) * delta_t - v * Sqr(delta_t))

Cells(12, 2) = delta_t
Cells(13, 2) = u
Cells(14, 2) = d
 For i = 0 To n
Cells(7, 7 + i + 1) = i
Next i

Cells(8, 8) = s0

For j = 1 To n
For k = 0 To j

If j > k Then
Cells(8 + k, 8 + j) = Cells(8 + k, 8 + j - 1) * u
End If

If j = k Then
Cells(8 + k, 8 + j) = Cells(8 + k - 1, 8 + j - 1) * d

End If

Next k

Next j

For a = 0 To n

If Cells(8 + a, 8 + n) < 25 Then

Cells(8 + a, 8 + n + 1) = 1000

ElseIf Cells(8 + a, 8 + n) < 40 Then

Cells(8 + a, 8 + n + 1) = 1000 + (Cells(8 + a, 8 + n) - 25) * 170

Else

Cells(8 + a, 8 + n + 1) = 1000 + (40 - 25) * 170

End If
 Next a

discountfactor = Exp(-r * delta_t)

For b = 0 To n

Cells(26 + b, 20) = Cells(8 + b, 21)

Next b

For c = 1 To n
For d = 0 To n - c

Cells(26 + d, 20 - c) = (Cells(26 + d, 20 - c + 1) + Cells(26 + d + 1, 20 - c + 1))

* 0.5 * discountfactor
Next d

Next c

End Sub
Private Sub CommandButton1_Click()

s = Cells(4, 2)
k = Cells(5, 2)
r = Cells(6, 2)
q = Cells(8, 2)
T = Cells(12, 2)
v = Cells(13, 2)
n = Cells(15, 2)
iopt = Cells(16, 2)
iea = Cells(16, 3)

Cells(22, 2) = s 'initializes s0

delta_t = T / n

u = Exp(v * Sqr(delta_t))
d=1/u

p = (Exp(r * delta_t) - d) / (u - d)

Cells(21, 2) = 0

Dim temp() As Variant

For i = 1 To n 'draw CRR tree

Cells(21, 2 + i) = i ' set time label

Cells(22, 2 + i) = Cells(22, 2 + i - 1) * u

For j = 1 To n
 Cells(22 + j, 2 + i) = Cells(22 + j - 1, 2 + i - 1) * d

Next j

Next i

Cells(15, 6) = BinOptionValue(1, iopt, iea, s, k, r, q, n, T, v)

End Sub

Function BinOptionValue(imod, iopt, iea, s, k, r, q, n, T, v)

Dim delta_t, erdt, ermqdt, u, d, d1, d2, p, pdash

Dim i As Integer, j As Integer

Dim temp() As Variant

If imod = 2 Then n = Application.Odd(n)

ReDim temp(n)

If s > 0 And k > 0 And T > 0 Then

delta_t = T / n
erdt = Exp(r * delta_t)
ermqdt = Exp((r - q) * delta_t)

If imod = 0 Then 'JR

rnmut = (r - q - 0.5 * v ^ 2) * delta_t
u = Exp(rnmut + v * Sqr(delta_t))
d = Exp(rnmut - v * Sqr(delta_t))
p = 0.5
ElseIf imod = 1 Then 'CRR
u = Exp(v * Sqr(delta_t))
d=1/u
p = (Exp((r - q) * delta_t) - d) / (u - d)
Else 'LR
d1 = (Log(s / k) + ((r - q) + 0.5 * v ^ 2) * T) / (v * Sqr(T))
d2 = d1 - v * Sqr(T)
p = PPNormInv(d2, n)
pdash = PPNormInv(d1, n)
u = ermqdt * (pdash / p)
d = ermqdt * ((1 - pdash) / (1 - p))
End If

For i = 0 To n
temp(i) = Application.Max(iopt * ((s * u ^ (i)) * (d ^ (n - i)) - k), 0)
Next i

For j = n - 1 To 0 Step -1
For i = 0 To j

temp(i) = (p * temp(i + 1) + (1 - p) * temp(i)) / erdt

 If iea = 2 Then
temp(i) = Application.Max(temp(i), iopt * ((s * u ^ (i)) * (d ^ (j - i)) - k))
End If
Next i
Next j

BinOptionValue = temp(0)
Else
BinOptionValue = -1
End If

End Function

Function PPNormInv(z, n)
' Returns the Peizer-Pratt Inversion
' Only defined for n odd
' Used in LR Binomial Option Valuation

Dim c1
n = Application.Odd(n)
c1 = Exp(-((z / (n + 1 / 3 + 0.1 / (n + 1))) ^ 2) * (n + 1 / 6))
PPNormInv = 0.5 + Sgn(z) * Sqr((0.25 * (1 - c1)))
End Function

Sub shareprice()

Dim n As Integer
Dim S, k, r, q, T, sigma As Double
Randomize
Range("B21:z1000").Select
Selection.ClearContents

S = Cells(4, 2)
k = Cells(5, 2)
r = Cells(6, 2)
q = Cells(8, 2)
 T = Cells(10, 2) - Cells(9, 2)
sigma = Cells(12, 2)
n = Cells(14, 2)

delta_t = T / n

Cells(21, 3) = S
Cells(21, 2) = 0
For i = 1 To n

Cells(21 + i, 2) = i
Cells(21 + i, 3) = Cells(21 + i - 1, 3) * Exp((r - q - 0.5 * sigma ^ (2)) * delta_t + sigma
* Sqr(delta_t) * Application.NormSInv(Rnd))
Next i

End Sub
Function MCOptionValue(iopt, S, k, r, q, T, sigma, nsim)

Dim sum, S1, s2, payoff1, payoff2 As Double

Randomize
sum = 0

For i = 1 To nsim
S1 = S * Exp((r - q - 0.5 * sigma ^ (2)) * T + sigma * Sqr(T) *
Application.NormSInv(Rnd))
s2 = S * Exp((r - q - 0.5 * sigma ^ (2)) * T - sigma * Sqr(T) *
Application.NormSInv(Rnd))

payoff1 = Application.Max(iopt * (S1 - k), 0)

payoff2 = Application.Max(iopt * (s2 - k), 0)

sum = sum + 0.5 * (payoff1 + payoff2)

Next i

MCOptionValue = (Exp(-r * T) * sum) / nsim

End Function

Function BinValue(imod, S, k, r, sigma, n, T, cr)

'imod=1
'imod=2
'imod=3 callable
'imod=4 callable+putable
 delta_t = T / n

Dim temp() As Variant

ReDim temp(n)

u = Exp(sigma * Sqr(delta_t))
d=1/u
p = (Exp(r * delta_t) - d) / (u - d)

For i = 0 To n
temp(i) = Application.Max(S * u ^ (n - i) * d ^ (i) * cr, k)
Next i

For i = n - 1 To 0 Step -1

For j = 0 To i
If imod = 1 Then

temp(j) = ((1 - p) * temp(j + 1) + p * temp(j)) * Exp(-r * delta_t)

End If

If imod = 2 Then

temp(j) = Application.Max(((1 - p) * temp(j + 1) + p * temp(j)) * Exp(-r *

delta_t), S * d ^ (j) * u ^ (i - j) * cr)

End If

If imod = 3 Then

If i >= Round(n / 2) Then

temp(j) = Application.Min(102, Application.Max(((1 - p) * temp(j + 1) + p *

temp(j)) * Exp(-r * delta_t), S * d ^ (j) * u ^ (i - j) * cr))

Else
 temp(j) = Application.Max(((1 - p) * temp(j + 1) + p * temp(j)) * Exp(-r *
delta_t), S * d ^ (j) * u ^ (i - j) * cr)
End If

End If

If imod = 4 Then

If i = Round(n / 2) Then
temp(j) = Application.Max(((1 - p) * temp(j + 1) + p * temp(j)) * Exp(-r *
delta_t), S * d ^ (j) * u ^ (i - j) * cr, 103)

End If

If i > Round(n / 2) Then

temp(j) = Application.Min(102, Application.Max(((1 - p) * temp(j + 1) + p *
temp(j)) * Exp(-r * delta_t), S * d ^ (j) * u ^ (i - j) * cr))
End If

If i < Round(n / 2) Then

temp(j) = Application.Max(((1 - p) * temp(j + 1) + p * temp(j)) * Exp(-r *
delta_t), S * d ^ (j) * u ^ (i - j) * cr)
End If

End If

Next j
Next i

BinValue = temp(0)

End Function

Function Halton1(n, b) As Double

 Dim h As Double, f As Double
Dim n1 As Integer, n0 As Integer, r As Integer
n0 = n
h=0
f=1/b
Do While n0 > 0
n1 = Int(n0 / b)
r = n0 - n1 * b
h=h+f*r
f=f/b
n0 = n1
Loop
Halton1 = h
End Function

Function BoxMullerNormSInv1(phix1 As Double, phix2 As Double) As Double

' Replaces NormSInv for quasi-random sequences (eg Faure)

' See Box and Muller

Dim h1, h2, vlog, norm1

h1 = phix1
h2 = phix2
vlog = Sqr(-2 * Log(h1))
norm1 = vlog * Cos(2 * Application.Pi() * h2)
BoxMullerNormSInv1 = norm1

End Function

Function BoxMullerNormSInv2(phix1 As Double, phix2 As Double) As Double

' Replaces NormSInv for quasi-random sequences (eg Faure)

' See Box and Muller

Dim h1, h2, vlog, norm2

h1 = phix1
 h2 = phix2
vlog = Sqr(-2 * Log(h1))
norm2 = vlog * Sin(2 * Application.Pi() * h2)
BoxMullerNormSInv2 = norm2

End Function

Function QMCOptionValue(iopt, S, X, r, q, tyr, sigma, nsim)

' Simple-ish Monte-Carlo simulation to value BS Option

' Uses quasi-random Normal variate (-qrandns)
' Uses FaureBase2 fn
' Uses MoroNormSInv fn

Dim rnmut, sigt, sum, S1, qrandns

Dim i As Integer, iskip As Integer
rnmut = (r - q - 0.5 * sigma ^ 2) * tyr
sigt = sigma * Sqr(tyr)
iskip = (2 ^ 4) - 1
sum = 0

For i = 1 To nsim
qrandns = Application.NormSInv(Halton1(i + iskip, 2))
S1 = S * Exp(rnmut + qrandns * sigt)
sum = sum + Application.Max(iopt * (S1 - X), 0)
Next i

QMCOptionValue = Exp(-r * tyr) * sum / nsim

End Function

Private Sub CommandButton1_Click()

S = Cells(3, 2)
k = Cells(4, 2)
T = Cells(5, 2)
r = Cells(6, 2)
 sigma = Cells(7, 2)
facevalue = Cells(8, 2)
nt = Cells(9, 2)
ns = Cells(10, 2)
delta_t = T / nt

AA = 0
X=0
optionValue = 0

Dim temp() As Variant

ReDim temp(nt)
Randomize
temp(0) = S

For j = 1 To ns 'run simulation

For i = 1 To nt 'construct stock price series

temp(i) = temp(i - 1) * Exp((r - 0.5 * sigma ^ (2)) * delta_t + sigma *

Sqr(delta_t) * Application.NormSInv(Rnd))

If i > nt - 32 And i < nt - 1 Then

AA = AA + temp(i)
End If

Next i
AA = AA / 30
X = Exp(-r * T) * Application.Max(AA - k, 0) * (facevalue / S)

optionValue = optionValue + X
Next j

optionValue = optionValue / ns
Cells(3, 7) = optionValue
End Sub

Function Halton1(n, b) As Double

Dim h As Double, f As Double

Dim n1 As Integer, n0 As Integer, r As Integer
n0 = n
h=0
f=1/b
Do While n0 > 0
n1 = Int(n0 / b)
r = n0 - n1 * b
h=h+f*r
f=f/b
n0 = n1
Loop
Halton1 = h
End Function
Function BSOptionValue(iopt, s, k, v, d, r, T)

Dim edt, ert, d1, d2

edt = Exp(-d * T)
ert = Exp(-r * T)
If s > 0 And k > 0 And v >= 0 And d >= 0 And r >= 0 And T > 0 Then

d1 = (Log(s / k) + (r - d + 0.5 * v * v) * T) / (v * Sqr(T))

d2 = d1 - v * Sqr(T)

BSOptionValue = iopt * (s * edt * Application.NormSDist(iopt * d1) - k * ert *

Application.NormSDist(iopt * d2))

Else

MsgBox ("Wrong Input")

BSOptionValue = -1

End If

End Function

-----------------------------------------------------------------------------------------

Function DOPut(s, X, r, q, tyr, sigma, Sb)

Dim eqt, ert, NDOne, NDTwo, NDThree, NDFour, NDFive, NDSix, NDSeven,
NDEight, a, b
eqt = Exp(-q * tyr)
ert = Exp(-r * tyr)
a = (Sb / s) ^ (-1 + (2 * r / sigma ^ 2))
b = (Sb / s) ^ (1 + (2 * r / sigma ^ 2))
If s > 0 And X > 0 And tyr > 0 And sigma > 0 Then
NDOne = Application.NormSDist(BSDOne(s, X, r, q, tyr, sigma))
NDTwo = Application.NormSDist(BSDTwo(s, X, r, q, tyr, sigma))
NDThree = Application.NormSDist(BSDThree(s, X, r, q, tyr, sigma, Sb))
 NDFour = Application.NormSDist(BSDFour(s, X, r, q, tyr, sigma, Sb))
NDFive = Application.NormSDist(BSDFive(s, X, r, q, tyr, sigma, Sb))
NDSix = Application.NormSDist(BSDSix(s, X, r, q, tyr, sigma, Sb))
NDSeven = Application.NormSDist(BSDSeven(s, X, r, q, tyr, sigma, Sb))
NDEight = Application.NormSDist(BSDEight(s, X, r, q, tyr, sigma, Sb))
DOPut = X * ert * (NDFour - NDTwo - a * (NDSeven - NDFive)) - s * eqt *
(NDThree - NDOne - b * (NDEight - NDSix))
Else
DOPut = -1
End If
End Function

---------------------------------------------------------------------------------------------------
Function BSDOne(s, X, r, q, tyr, sigma)
BSDOne = (Log(s / X) + (r - q + 0.5 * sigma ^ 2) * tyr) / (sigma * Sqr(tyr))
End Function
Function BSDTwo(s, X, r, q, tyr, sigma)
BSDTwo = BSDOne(s, X, r, q, tyr, sigma) - sigma * Sqr(tyr)
End Function
Function BSDThree(s, X, r, q, tyr, sigma, Sb)
BSDThree = (Log(s / Sb) + (r - q + 0.5 * sigma ^ 2) * tyr) / (sigma * Sqr(tyr))
End Function
Function BSDFour(s, X, r, q, tyr, sigma, Sb)
BSDFour = BSDThree(s, X, r, q, tyr, sigma, Sb) - sigma * Sqr(tyr)
End Function
Function BSDFive(s, X, r, q, tyr, sigma, Sb)
BSDFive = (Log(s / Sb) - (r - q - 0.5 * sigma ^ 2) * tyr) / (sigma * Sqr(tyr))
End Function
Function BSDSix(s, X, r, q, tyr, sigma, Sb)
BSDSix = BSDFive(s, X, r, q, tyr, sigma, Sb) - sigma * Sqr(tyr)
End Function
Function BSDSeven(s, X, r, q, tyr, sigma, Sb)
BSDSeven = (Log(s * X / Sb ^ 2) - (r - q - 0.5 * sigma ^ 2) * tyr) / (sigma * Sqr(tyr))
End Function
Function BSDEight(s, X, r, q, tyr, sigma, Sb)
BSDEight = BSDSeven(s, X, r, q, tyr, sigma, Sb) - sigma * Sqr(tyr)
End Function
--------------------------------------------------------------------------------------------------------

Function TRF(e, e0, kp, kc, r, rf, T, sigma)

TRF = Application.Max(6.12 - e, 0) - 2 * Application.Max(e - 6.18, 0) -

BSOptionValue(-1, e0, kp, sigma, rf, r, T) + 2 * BSOptionValue(1, e0, kc, sigma, rf, r, T)

If e >= 6.18 Then

TRF = TRF - 2 * 0.06

End If

End Function
---------------------------------------------------------------------------------------------------

Function AssetPaths(s, r, q, T, sigma, nt, ns)

Dim dt
Dim spath()
Randomize
dt = T / nt
jskip = (2 ^ 4) - 1
ReDim spath(nt, 1 To ns)

For i = 1 To ns
spath(0, i) = s
For j = 1 To nt
spath(j, i) = spath(j - 1, i) * Exp(((r - q) - 0.5 * sigma ^ (2)) * dt + sigma * Sqr(dt) *
Application.NormSInv(Rnd))
Next j

Next i

AssetPaths = spath
End Function

Function BarrierOption(UpOrDown, InOrOut, iopt, s, k, b, r, q, sigma, T, nt, ns)

' if UpOrDown=0 (Down) UpOrDown=1 (Up)

' if InOrOut =0 (Out) InOrOut =1 (In)
' iopt = 1 (call) iopt=-1 (put)

Dim payoff, sum, cross

Dim temp(1)
Dim j, i As Integer

Dim spath()
ReDim spath(nt, 1 To ns)
sum = 0
cross = 0
spath = AssetPaths(s, r, q, T, sigma, nt, ns)

'''''''''''''''''''''''''''''''''''''
If UpOrDown = 0 And InOrOut = 0 And iopt = -1 Then 'DOPut

If b >= s Then
MsgBox ("Barrier price must be less than current price")
ElseIf b >= k Then
MsgBox ("Barrier price must be less than strike price")

Else

For i = 1 To ns
payoff = Application.Max(iopt * (spath(nt, i) - k), 0)
For j = 1 To nt
If spath(j, i) <= b Then
payoff = 0
j = nt + 1
cross = cross + 1
 End If
Next j
sum = sum + payoff
Next i

temp(0) = sum * Exp(-r * T) / ns

temp(1) = cross

BarrierOption = temp
End If

End If

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

If UpOrDown = 0 And InOrOut = 0 And iopt = 1 Then 'DOCall

If b >= s Then
MsgBox ("Barrier price must be less than current price")
Else
For i = 1 To ns
payoff = Application.Max(iopt * (spath(nt, i) - k), 0)
For j = 1 To nt

If spath(j, i) <= b Then

payoff = 0
j = nt + 1
cross = cross + 1
End If

Next j
sum = sum + payoff
Next i

temp(0) = sum * Exp(-r * T) / ns

temp(1) = cross
 BarrierOption = temp
End If
End If

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

If UpOrDown = 0 And InOrOut = 1 And iopt = -1 Then 'DIPut

For i = 1 To ns
payoff = 0

For j = 1 To nt
If spath(j, i) <= b Then
payoff = Application.Max(iopt * (spath(nt, i) - k), 0)
j = nt + 1
cross = cross + 1
End If

Next j
sum = sum + payoff
Next i

temp(0) = sum * Exp(-r * T) / ns

temp(1) = cross

BarrierOption = temp
End If

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

If UpOrDown = 0 And InOrOut = 1 And iopt = 1 Then 'DICall

For i = 1 To ns
payoff = 0

For j = 1 To nt
 If spath(j, i) <= b Then
payoff = Application.Max(iopt * (spath(nt, i) - k), 0)
j = nt + 1
cross = cross + 1
End If

Next j
sum = sum + payoff
Next i

temp(0) = sum * Exp(-r * T) / ns

temp(1) = cross

BarrierOption = temp
End If

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

If UpOrDown = 1 And InOrOut = 0 And iopt = -1 Then 'UOPut

If b <= s Then
MsgBox ("Barrier price must be greater than current price")
Else

For i = 1 To ns
payoff = Application.Max(iopt * (spath(nt, i) - k), 0)

For j = 1 To nt
If spath(j, i) >= b Then
payoff = 0
j = nt + 1
cross = cross + 1
End If

Next j
sum = sum + payoff
Next i
 temp(0) = sum * Exp(-r * T) / ns
temp(1) = cross

BarrierOption = temp
End If
End If

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

If UpOrDown = 1 And InOrOut = 0 And iopt = 1 Then 'UOCall

If b <= s Then
MsgBox ("Barrier price must be greater than current price")
ElseIf b <= k Then
MsgBox ("Barrier price must be greater than strike price")
Else
For i = 1 To ns
payoff = Application.Max(iopt * (spath(nt, i) - k), 0)

For j = 1 To nt
If spath(j, i) >= b Then
payoff = 0
j = nt + 1
cross = cross + 1
End If

Next j
sum = sum + payoff
Next i

temp(0) = sum * Exp(-r * T) / ns

temp(1) = cross

BarrierOption = temp
End If
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

If UpOrDown = 1 And InOrOut = 1 And iopt = -1 Then 'UIPut

For i = 1 To ns
payoff = 0

For j = 1 To nt
If spath(j, i) >= b Then
payoff = Application.Max(iopt * (spath(nt, i) - k), 0)
j = nt + 1
cross = cross + 1
End If

Next j
sum = sum + payoff
Next i

temp(0) = sum * Exp(-r * T) / ns

temp(1) = cross

BarrierOption = temp
End If

If UpOrDown = 1 And InOrOut = 1 And iopt = 1 Then 'UICall

For i = 1 To ns
payoff = 0

For j = 1 To nt
If spath(j, i) >= b Then
payoff = Application.Max(iopt * (spath(nt, i) - k), 0)
j = nt + 1
cross = cross + 1
 End If

Next j
sum = sum + payoff
Next i

temp(0) = sum * Exp(-r * T) / ns

temp(1) = cross

BarrierOption = temp
End If

End Function

Private Sub CommandButton1_Click()

s0 = Cells(2, 2)
k = Cells(3, 2)
sMax = Cells(4, 2)
ds = Cells(5, 2)
T = Cells(6, 2)
dt = Cells(7, 2)
r = Cells(8, 2)
q = Cells(9, 2)
sigma = Cells(10, 2)
iopt = Cells(12, 2)

mPrevious = Cells(6, 31)

nPrevious = Cells(6, 30)

Dim n, m, u
n = T / dt
m = sMax / ds
u = s0 / ds
Range(Cells(15, 1), Cells(15 + mPrevious + 1, 1 + nPrevious + 1)).ClearContents

Cells(15, 1) = " S\t"

Cells(15, 2) = 0

'run time label

For i = 1 To n
Cells(15, 2 + i) = Cells(15, 2) + i * dt
Next i

Cells(16, 1) = sMax

'run price label

For i = 1 To m

Cells(16 + i, 1) = Cells(16 + i - 1, 1) - ds
Next i

For i = 0 To n 'run column

For j = m To 0 Step -1 'run row

If i = 0 Then ' column

Cells(16 + m - j, 2 + n - i) = Application.Max(iopt * (j * ds - k), 0)

Else ' columnSmax S0 fij

If j = m Or j = 0 Then
 Cells(16 + m - j, 2 + n - i) = Application.Max(iopt * (j * ds - k), 0)

Else ' column fij

aj = 0.5 * dt * (sigma ^ (2) * j ^ (2) - r * j)

bj = 1 - dt * (sigma ^ (2) * j ^ (2) + r)
cj = 0.5 * dt * (sigma ^ (2) * j ^ (2) + r * j)

Cells(16 + m - j, 2 + n - i) = aj * Cells(16 + m - j + 1, 2 + n - i + 1) + bj *
Cells(16 + m - j, 2 + n - i + 1) + cj * Cells(16 + m - j - 1, 2 + n - i + 1)

End If

End If

Next j
Next i

Cells(4, 7) = Cells(16 + m - u, 2)

Cells(6, 30) = n
Cells(6, 31) = m

End Sub
'calculate probability

Function pro(a, T, n)

delta_t = T / n
M = -a * delta_t

Dim temp()
ReDim temp(2 * n + 1, n, 3)

For i = 0 To n 'run time(column)

For j = -i To i Step 1 'run row

For k = 0 To 2 ' k=0 prob_D k=1 prob_M k=2 prob_U

If k = 0 Then
temp(j + i, i, k) = 1 / 6 + ((j ^ (2) * M ^ (2)) - j * M) * 0.5
ElseIf k = 1 Then
temp(j + i, i, k) = 2 / 3 - j ^ (2) * M ^ (2)
Else
temp(j + i, i, k) = 1 / 6 + ((j ^ (2) * M ^ (2)) + j * M) * 0.5
End If

Next k
Next j

Next i

pro = temp
End Function

' calculate R(i,j)

Function C_R(a, sigma, T, n)

term = 0.1 'term structure

delta_t = T / n
M = -a * delta_t
delta_r = Sqr(3) * sigma * Sqr(delta_t)

Dim P, temp As Double

temp = 0

Dim Q(), alpha(), R()

ReDim Q(2 * n + 1, n), alpha(n), R(2 * n + 1, n)

prob = pro(a, T, n) 'include Prob

Q(0, 0) = 0.1 'initial Q(0,0)

'calculate Q(i,j)

For i = 1 To n

For j = -i To i Step 1

If i = 1 Then 'when t = 1

If j = -1 Then
Q(j + i, i) = prob(0, 0, 0) * Exp(-0.1 * delta_t)
ElseIf j = 0 Then
Q(j + i, i) = prob(0, 0, 1) * Exp(-0.1 * delta_t)
 Else
Q(j + i, i) = prob(0, 0, 2) * Exp(-0.1 * delta_t)
End If
Else 'when t>1

If j = -i Then
Q(j + i, i) = prob(0, i - 1, 0) * Q(0, i - 1) * Exp(-(alpha(i - 1) + (j + 1) * delta_r) *
delta_t)
ElseIf j = -i + 1 Then
Q(j + i, i) = prob(0, i - 1, 1) * Q(0, i - 1) * Exp(-(alpha(i - 1) + j * delta_r) *
delta_t) + prob(1, i - 1, 0) * Q(1, i - 1) * Exp(-(alpha(i - 1) + (j + 1) * delta_r) * delta_t)
ElseIf j = i - 1 Then
Q(j + i, i) = prob(2 * (i - 1), i - 1, 1) * Q(2 * (i - 1), i - 1) * Exp(-(alpha(i - 1) + j *
delta_r) * delta_t) + prob(2 * (i - 1) - 1, i - 1, 2) * Q(2 * (i - 1) - 1, i - 1) * Exp(-(alpha(i -
1) + (j - 1) * delta_r) * delta_t)
ElseIf j = i Then
Q(j + i, i) = prob(2 * (i - 1), i - 1, 2) * Q(2 * (i - 1), i - 1) * Exp(-(alpha(i - 1) + (j -
1) * delta_r) * delta_t)
Else
Q(j + i, i) = prob(j + i, i - 1, 0) * Q(j + i, i - 1) * Exp(-(alpha(i - 1) + (j + 1) *
delta_r) * delta_t) + prob(j + i - 1, i - 1, 1) * Q(j + i - 1, i - 1) * Exp(-(alpha(i - 1) + j *
delta_r) * delta_t) + prob(j + i - 2, i - 1, 2) * Q(j + i - 2, i - 1) * Exp(-(alpha(i - 1) + (j - 1)
* delta_r) * delta_t)
End If

End If
temp = temp + Q(j + i, i) * Exp(-j * delta_r * delta_t)

Next j

P = Exp(-0.1 * ((i + 1) * delta_t))

alpha(i) = (Log(temp) - Log(P)) / delta_t
temp = 0

Next i
 R(0, 0) = Q(0, 0)

For i = 1 To n
For j = 0 To 2 * n

R(j, i) = alpha(i) + (j - i) * delta_r

Next j
Next i

C_R = R

End Function

Private Sub CommandButton1_Click()

'inputs

n_bar = Cells(2, 100)

a = Cells(3, 2)
sigma = Cells(4, 2)
term = Cells(5, 2)
T = Cells(6, 2)
n = Cells(7, 2)

delta_t = T / n

M = -a * delta_t
Cells(12, 2) = M

j_max = Round(-0.184 / M)
delta_r = Sqr(3) * sigma * Sqr(delta_t)
Cells(13, 2) = j_max
Cells(14, 2) = -j_max
Cells(15, 2) = delta_r
 'Dim prob()
'ReDim prob(2 * n + 1, 2, 3)

Dim value()
ReDim value(2 * n + 1, n)

prob = pro(a, T, n) 'prob(j,direction)

R = C_R(a, sigma, T, n)

Range(Cells(12, 3), Cells(12 + 2 * n_bar + 2, 3 + n_bar + 1)).ClearContents

'run time label

Cells(12, 3) = " t"

Cells(12, 4) = 0
For i = 1 To n
Cells(12, 4 + i) = i * delta_t
Next i

If n > j_max Then ' n>j_max payoffs

'run payoffs at time T ( payoffs R R[,j_max])

For i = 0 To 2 * j_max
 value(i, n) = Application.Max(100 * (R(i, j_max) - 0.11), 0)
Cells(14 + i, 4 + n) = R(2 * j_max - i, j_max)
Next i

'run payoffs at t where 0<= t <= T-delta_t

For i = n - 1 To 0 Step -1

If i >= j_max Then

For j = 0 To 2 * j_max

If j = 0 Then 'j=0 payoff

value(j, i) = (prob(i - j_max, i, 1) * value(j, i + 1) + prob(i - j_max, i, 2) * value(j +

1, i + 1) + prob(i - j_max, i, 0) * value(j_max, i + 1)) / (1 + R(j, j_max))

ElseIf j = 2 * j_max Then 'j=2*j_max payoff

value(j, i) = (prob(i + j_max, i, 2) * value(j_max, i + 1) + prob(i + j_max, i, 0) *

value(2 * j_max - 1, i + 1) + prob(i + j_max, i, 1) * value(2 * j_max, i + 1)) / (1 + R(j,
j_max))

Else ' O.W. payoffs

value(j, i) = (prob(j + (n - j_max), i, 0) * value(j - 1, i + 1) + prob(j + (n - j_max), i,

1) * value(j, i + 1) + prob(j + (n - j_max), i, 2) * value(j + 1, i + 1)) / (1 + R(j, j_max))

End If

Cells(14 + j, 4 + i) = R(2 * j_max - j, j_max)

Next j

Else
 For j = 0 To 2 * i

value(j, i) = (prob(j, i, 0) * value(j, i + 1) + prob(j, i, 1) * value(j + 1, i + 1) +

prob(j, i, 2) * value(j + 2, i + 1)) / (1 + R(j, i))
Cells(14 + j, 4 + i) = R(2 * i - j, i)
Next j

End If

Next i

Else ' n>j_max payoffs

'run payoffs at time T

For i = 0 To 2 * n

value(i, n) = Application.Max(100 * (R(i, n) - 0.11), 0)

Cells(14 + i, 4 + n) = R(2 * n - i, n)
Next i

'run payoffs at t where 0<= t <= T-delta_t

For i = n - 1 To 0 Step -1
For j = 0 To 2 * i
value(j, i) = (prob(j, i, 0) * value(j, i + 1) + prob(j, i, 1) * value(j + 1, i + 1) + prob(j,
i, 2) * value(j + 2, i + 1)) / (1 + R(j, i))
Cells(14 + j, 4 + i) = R(2 * i - j, i)
Next j
Next i
End If

Cells(10, 2) = value(0, 0)

Cells(2, 100) = n

End Sub