Appendix 18A Excel VBA Code —Binomial Option Pricing Model ...

Appendix 18A Excel VBA Code Binomial Option Pricing Model (18.4 and 18.7) By Cheng Few Lee Joseph Finnerty John Lee Alice C Lee Donald Wort 2 It is important to note that the thing that makes Microsoft Excel powerful is that it offers a powerful professional programming language called VBA. This section shows the VBA code that generated the Decision Trees for the Binomial Option pricing model. This code is in the form frmBinomiaOption. The procedure cmdCalculate_Click is the first procedure to run.

3 '/*************************************************************************** '/ Relationship Between the Binomial OPM '/ and Black-Scholes OPM: '/ Decision Tree and Microsoft Excel Approach '/ '/ by John Lee '/ [email protected] '/ All Rights Reserved '/*************************************************************************** Option Explicit Dim mwbTreeWorkbook As Workbook Dim mwsTreeWorksheet As Worksheet Dim mwsCallTree As Worksheet Dim mwsPutTree As Worksheet Dim mwsBondTree As Worksheet Dim mdblPFactor As Double Dim mBinomialCalc As Long Dim mCallPrice As Double 'jcl 12/8/2008 Dim mPutPrice As Double 'jcl 12/8/2008

4 '/************************************************** '/Purpose: Keep track the numbers of binomial calc '/************************************************* Property Let BinomialCalc(l As Long) mBinomialCalc = l End Property Property Get BinomialCalc() As Long BinomialCalc = mBinomialCalc End Property Property Set TreeWorkbook(wb As Workbook) Set mwbTreeWorkbook = wb End Property Property Get TreeWorkbook() As Workbook Set TreeWorkbook = mwbTreeWorkbook End Property Property Set TreeWorksheet(ws As Worksheet) Set mwsTreeWorksheet = ws End Property Property Get TreeWorksheet() As Worksheet Set TreeWorksheet = mwsTreeWorksheet End Property

5 Property Set CallTree(ws As Worksheet) Set mwsCallTree = ws End Property Property Get CallTree() As Worksheet Set CallTree = mwsCallTree End Property Property Set PutTree(ws As Worksheet) Set mwsPutTree = ws End Property Property Get PutTree() As Worksheet Set PutTree = mwsPutTree End Property Property Set BondTree(ws As Worksheet) Set mwsBondTree = ws End Property Property Get BondTree() As Worksheet Set BondTree = mwsBondTree End Property

Property Let CallPrice(dCallPrice As Double) '12/8/2008 mCallPrice = dCallPrice End Property Property Get CallPrice() As Double Let CallPrice = mCallPrice End Property Property Let PutPrice(dPutPrice As Double) '12/10/2008 mPutPrice = dPutPrice End Property Property Get PutPrice() As Double '12/10/2008 Let PutPrice = mPutPrice End Property Property Let PFactor(r As Double) Dim dRate As Double dRate = ((1 + r) - Me.txtBinomialD) / (Me.txtBinomialU - Me.txtBinomialD) 6 Let mdblPFactor = dRate End Property

Property Get PFactor() As Double Let PFactor = mdblPFactor End Property Property Get qU() As Double Dim dblDeltaT As Double Dim dblDown As Double Dim dblUp As Double Dim dblR As Double dblDeltaT = Me.txtTimeT / Me.txtBinomialN dblR = Exp(Me.txtBinomialr * dblDeltaT) dblUp = Exp(Me.txtSigma * VBA.Sqr(dblDeltaT)) dblDown = Exp(-Me.txtSigma * VBA.Sqr(dblDeltaT)) 7 qU = (dblR - dblDown) / (dblR * (dblUp - dblDown)) End Property Property Get qD() As Double

Dim dblDeltaT As Double Dim dblDown As Double Dim dblUp As Double Dim dblR As Double dblDeltaT = Me.txtTimeT / Me.txtBinomialN dblR = Exp(Me.txtBinomialr * dblDeltaT) dblUp = Exp(Me.txtSigma * VBA.Sqr(dblDeltaT)) dblDown = Exp(-Me.txtSigma * VBA.Sqr(dblDeltaT)) qD = (dblUp - dblR) / (dblR * (dblUp - dblDown)) End Property Private Sub chkBinomialBSApproximation_Click() On Error Resume Next 'Time and Sigma only BlackScholes parameter Me.txtTimeT.Visible = Me.chkBinomialBSApproximation Me.lblTimeT.Visible = Me.chkBinomialBSApproximation Me.txtSigma.Visible = Me.chkBinomialBSApproximation Me.lblSigma.Visible = Me.chkBinomialBSApproximation txtTimeT_Change

8 End Sub Private Sub cmdCalculate_Click() Me.Hide BinomialOption Unload Me End Sub Private Sub cmdCancel_Click() Unload Me End Sub 9

Private Sub txtBinomialN_Change() 'jcl 12/8/2008 On Error Resume Next If Me.chkBinomialBSApproximation Then Me.txtBinomialU = Exp(Me.txtSigma * Sqr(Me.txtTimeT / Me.txtBinomialN)) Me.txtBinomialD = Exp(-Me.txtSigma * Sqr(Me.txtTimeT / Me.txtBinomialN)) End If End Sub Private Sub txtTimeT_Change() 10 'jcl 12/8/2008 On Error Resume Next If Me.chkBinomialBSApproximation Then Me.txtBinomialU = Exp(Me.txtSigma * Sqr(Me.txtTimeT / Me.txtBinomialN)) Me.txtBinomialD = Exp(-Me.txtSigma * Sqr(Me.txtTimeT / Me.txtBinomialN)) End If End Sub Private Sub UserForm_Initialize() With Me

.txtBinomialS = 20 .txtBinomialX = 20 .txtBinomialD = 0.95 .txtBinomialU = 1.05 .txtBinomialN = 4 .txtBinomialr = 0.03 .txtSigma = 0.2 .txtTimeT = 4 11 Me.chkBinomialBSApproximation = False End With chkBinomialBSApproximation_Click Me.Hide End Sub Sub BinomialOption() Dim wbTree As Workbook Dim wsTree As Worksheet Dim rColumn As Range Dim ws As Worksheet

Set Me.TreeWorkbook = Workbooks.Add Set Me.BondTree = Me.TreeWorkbook.Worksheets.Add Set Me.PutTree = Me.TreeWorkbook.Worksheets.Add Set Me.CallTree = Me.TreeWorkbook.Worksheets.Add Set Me.TreeWorksheet = Me.TreeWorkbook.Worksheets.Add Set rColumn = Me.TreeWorksheet.Range("a1") 12 With Me .BinomialCalc = 0 .PFactor = Me.txtBinomialr .CallTree.Name = "Call Option Price" .PutTree.Name = "Put Option Price" .TreeWorksheet.Name = "Stock Price" .BondTree.Name = "Bond" End With

DecisionTree rCell:=rColumn, nPeriod:=Me.txtBinomialN + 1, _ dblPrice:=Me.txtBinomialS, sngU:=Me.txtBinomialU, _ sngD:=Me.txtBinomialD DecitionTreeFormat TreeTitle wsTree:=Me.TreeWorksheet, sTitle:="Stock Price " TreeTitle wsTree:=Me.CallTree, sTitle:="Call Option Pricing" TreeTitle wsTree:=Me.PutTree, sTitle:="Put Option Pricing" TreeTitle wsTree:=Me.BondTree, sTitle:="Bond Pricing" 13 Application.DisplayAlerts = False For Each ws In Me.TreeWorkbook.Worksheets If Left(ws.Name, 5) = "Sheet" Then ws.Delete Else ws.Activate ActiveWindow.DisplayGridlines = False ws.UsedRange.NumberFormat = "#,##0.0000_);(#,##0.0000)"

End If Next Application.DisplayAlerts = True Me.TreeWorksheet.Activate End Sub 14 Sub TreeTitle(wsTree As Worksheet, sTitle As String) wsTree.Range("A1:A5").EntireRow.Insert (xlShiftDown) With wsTree With .Cells(1) .Value = sTitle .Font.Size = 20 .Font.Italic = True End With With .Cells(2, 1) .Value = "Decision Tree" .Font.Size = 16 .Font.Italic = True End With With .Cells(3, 1)

.Value = "Price = " & Me.txtBinomialS & _ ",Exercise = " & Me.txtBinomialX & _ ",U = " & Format(Me.txtBinomialU, "#,##0.0000") & _ ",D = " & Format(Me.txtBinomialD, "#,##0.0000") & _ ",N = " & Me.txtBinomialN & _ ",R = " & Me.txtBinomialr .Font.Size = 14 End With With .Cells(4, 1) .Value = "Number of calculations: " & Me.BinomialCalc .Font.Size = 14 End With If wsTree Is Me.CallTree Then With .Cells(5, 1) .Value = "Binomial Call Price= " & Format(Me.CallPrice, "#,##0.0000") .Font.Size = 14 End With If Me.chkBinomialBSApproximation Then wsTree.Range("A6:A7").EntireRow.Insert (xlShiftDown)

15 With .Cells(6, 1) .Value = "Black-Scholes Call Price= " & Format(Me.BS_Call, "#,##0.0000") _ & ",d1=" & Format(Me.BS_D1, "#,##0.0000") _ & ",d2=" & Format(Me.BS_D2, "#,##0.0000") _ & ",N(d1)=" & Format(WorksheetFunction.NormSDist(BS_D1), "#,##0.0000") _ & ",N(d2)=" & Format(WorksheetFunction.NormSDist(BS_D2), "#,##0.0000") .Font.Size = 14 End With End If ElseIf wsTree Is Me.PutTree Then With .Cells(5, 1) .Value = "Binomial Put Price: " & Format(Me.PutPrice, "#,##0.0000") .Font.Size = 14 End With If Me.chkBinomialBSApproximation Then wsTree.Range("A6:A7").EntireRow.Insert (xlShiftDown)

With .Cells(6, 1) .Value = "Black-Scholes Put Price: " & Format(Me.BS_PUT, "#,##0.0000") .Font.Size = 14 End With End If End If 16 End With End Sub Sub BondDecisionTree(rPrice As Range, arCell As Variant, iCount As Long) Dim rBond As Range Dim rPup As Range Dim rPDown As Range Set rBond = Me.BondTree.Cells(rPrice.Row, rPrice.Column) Set rPup = Me.BondTree.Cells(arCell(iCount - 1).Row, arCell(iCount - 1).Column) Set rPDown = Me.BondTree.Cells(arCell(iCount).Row, arCell(iCount).Column) If rPup.Column = Me.TreeWorksheet.UsedRange.Columns.Count Then rPup.Value = (1 + Me.txtBinomialr) ^ (rPup.Column - 1)

rPDown.Value = rPup.Value End If 17 With rBond .Value = (1 + Me.txtBinomialr) ^ (rBond.Column - 1) .Borders(xlBottom).LineStyle = xlContinuous End With rPDown.Borders(xlBottom).LineStyle = xlContinuous With rPup .Borders(xlBottom).LineStyle = xlContinuous .Offset(1, 0).Resize((rPDown.Row - rPup.Row), 1). _ Borders(xlEdgeLeft).LineStyle = xlContinuous End With End Sub Sub PutDecisionTree(rPrice As Range, arCell As Variant, iCount As Long) Dim rCall As Range Dim rPup As Range Dim rPDown As Range

Set rCall = Me.PutTree.Cells(rPrice.Row, rPrice.Column) Set rPup = Me.PutTree.Cells(arCell(iCount - 1).Row, arCell(iCount - 1).Column) Set rPDown = Me.PutTree.Cells(arCell(iCount).Row, arCell(iCount).Column) 18 If rPup.Column = Me.TreeWorksheet.UsedRange.Columns.Count Then rPup.Value = WorksheetFunction.Max(Me.txtBinomialX - arCell(iCount - 1), 0) rPDown.Value = WorksheetFunction.Max(Me.txtBinomialX - arCell(iCount), 0) End If With rCall '12/10/2008 If Not Me.chkBinomialBSApproximation Then .Value = (Me.PFactor * rPup + (1 - Me.PFactor) * rPDown) / (1 + Me.txtBinomialr) Else .Value = (Me.qU * rPup) + (Me.qD * rPDown) End If

Me.PutPrice = .Value '12/8/2008 .Borders(xlBottom).LineStyle = xlContinuous End With 19 rPDown.Borders(xlBottom).LineStyle = xlContinuous With rPup .Borders(xlBottom).LineStyle = xlContinuous .Offset(1, 0).Resize((rPDown.Row - rPup.Row), 1). _ Borders(xlEdgeLeft).LineStyle = xlContinuous End With End Sub Sub CallDecisionTree(rPrice As Range, arCell As Variant, iCount As Long) Dim rCall As Range Dim rCup As Range Dim rCDown As Range

Set rCall = Me.CallTree.Cells(rPrice.Row, rPrice.Column) Set rCup = Me.CallTree.Cells(arCell(iCount - 1).Row, arCell(iCount - 1).Column) Set rCDown = Me.CallTree.Cells(arCell(iCount).Row, arCell(iCount).Column) 20 If rCup.Column = Me.TreeWorksheet.UsedRange.Columns.Count Then With rCup .Value = WorksheetFunction.Max(arCell(iCount - 1) - Me.txtBinomialX, 0) .Borders(xlBottom).LineStyle = xlContinuous End With With rCDown .Value = WorksheetFunction.Max(arCell(iCount) - Me.txtBinomialX, 0) .Borders(xlBottom).LineStyle = xlContinuous End With End If With rCall

If Not Me.chkBinomialBSApproximation Then .Value = (Me.PFactor * rCup + (1 - Me.PFactor) * rCDown) / (1 + Me.txtBinomialr) Else .Value = (Me.qU * rCup) + (Me.qD * rCDown) End If Me.CallPrice = .Value '12/8/2008 .Borders(xlBottom).LineStyle = xlContinuous End With rCup.Offset(1, 0).Resize((rCDown.Row - rCup.Row), 1). _ Borders(xlEdgeLeft).LineStyle = xlContinuous 21 End Sub

Sub DecitionTreeFormat() Dim rTree As Range Dim nColumns As Integer Dim rLast As Range Dim rCell As Range Dim lCount As Long Dim lCellSize As Long Dim vntColumn As Variant Dim iCount As Long Dim lTimes As Long Dim arCell() As Range Dim sFormatColumn As String Dim rPrice As Range 22 Application.StatusBar = "Formatting Tree.. " Set rTree = Me.TreeWorksheet.UsedRange nColumns = rTree.Columns.Count Set rLast = rTree.Columns(nColumns).EntireColumn.SpecialCells(xlCellTypeConstants, 23) lCellSize = rLast.Cells.Count For lCount = nColumns To 2 Step -1 sFormatColumn = rLast.Parent.Columns(lCount).EntireColumn.Address Application.StatusBar = "Formatting column " & sFormatColumn ReDim vntColumn(1 To (rLast.Cells.Count / 2), 1)

Application.StatusBar = "Assigning values to array for column " & _ rLast.Parent.Columns(lCount).EntireColumn.Address vntColumn = rLast.Offset(0, -1).EntireColumn.Cells(1).Resize(rLast.Cells.Count / 2, 1) rLast.Offset(0, -1).EntireColumn.ClearContents 23 ReDim arCell(1 To rLast.Cells.Count) lTimes = 1 Application.StatusBar = "Assigning cells to arrays. Total number of cells: " & lCellSize For Each rCell In rLast.Cells Application.StatusBar = "Array to column " & sFormatColumn & " Cells " & rCell.Row Set arCell(lTimes) = rCell lTimes = lTimes + 1 Next lTimes = 1

Application.StatusBar = "Formatting leaves for column " & sFormatColumn For iCount = 2 To lCellSize Step 2 24 Application.StatusBar = "Formatting leaves for cell " & arCell(iCount).Address If rLast.Cells.Count <> 2 Then Set rPrice = arCell(iCount).Offset(-1 * ((arCell(iCount).Row - arCell(iCount 1).Row) / 2), -1) rPrice.Value = vntColumn(lTimes, 1) Else Set rPrice = arCell(iCount).Offset(-1 * ((arCell(iCount).Row - arCell(iCount 1).Row) / 2), -1) rPrice.Value = vntColumn End If arCell(iCount).Borders(xlBottom).LineStyle = xlContinuous With arCell(iCount - 1) .Borders(xlBottom).LineStyle = xlContinuous .Offset(1, 0).Resize((arCell(iCount).Row - arCell(iCount - 1).Row), 1). _ Borders(xlEdgeLeft).LineStyle = xlContinuous End With lTimes = 1 + lTimes

CallDecisionTree rPrice:=rPrice, arCell:=arCell, iCount:=iCount PutDecisionTree rPrice:=rPrice, arCell:=arCell, iCount:=iCount BondDecisionTree rPrice:=rPrice, arCell:=arCell, iCount:=iCount Next Set rLast = rTree.Columns(lCount - 1).EntireColumn.SpecialCells(xlCellTypeConstants, 23) lCellSize = rLast.Cells.Count Next ' / outer next 25 rLast.Borders(xlBottom).LineStyle = xlContinuous Application.StatusBar = False End Sub '/********************************************************************* '/Purpse: To calculate the price value of every state of the binomial '/ decision tree '/*********************************************************************

Sub DecisionTree(rCell As Range, nPeriod As Integer, _ dblPrice As Double, sngU As Single, sngD As Single) Dim lIteminColumn As Long 26 If Not nPeriod = 1 Then 'Do Up DecisionTree rCell:=rCell.Offset(0, 1), nPeriod:=nPeriod - 1, _ dblPrice:=dblPrice * sngU, sngU:=sngU, _ sngD:=sngD 'Do Down DecisionTree rCell:=rCell.Offset(0, 1), nPeriod:=nPeriod - 1, _ dblPrice:=dblPrice * sngD, sngU:=sngU, _ sngD:=sngD End If lIteminColumn = WorksheetFunction.CountA(rCell.EntireColumn) If lIteminColumn = 0 Then rCell = dblPrice

Else If nPeriod <> 1 Then rCell.EntireColumn.Cells(lIteminColumn + 1) = dblPrice Else rCell.EntireColumn.Cells(((lIteminColumn + 1) * 2) - 1) = dblPrice Application.StatusBar = "The number of binomial calcs are : " & Me.BinomialCalc _ & " at cell " & rCell.EntireColumn.Cells(((lIteminColumn + 1) * 2) - 1).Address End If End If Me.BinomialCalc = Me.BinomialCalc + 1 27 End Sub Function BS_D1() As Double Dim dblNumerator As Double Dim dblDenominator As Double

On Error Resume Next dblNumerator = VBA.Log(Me.txtBinomialS / Me.txtBinomialX) + _ ((Me.txtBinomialr + Me.txtSigma ^ 2 / 2) * Me.txtTimeT) dblDenominator = Me.txtSigma * Sqr(Me.txtTimeT) BS_D1 = dblNumerator / dblDenominator End Function Function BS_D2() As Double On Error Resume Next BS_D2 = BS_D1 - (Me.txtSigma * VBA.Sqr(Me.txtTimeT)) 28 End Function Function BS_Call() As Double

BS_Call = (Me.txtBinomialS * WorksheetFunction.NormSDist(BS_D1)) _ - Me.txtBinomialX * Exp(-Me.txtBinomialr * Me.txtTimeT) * _ WorksheetFunction.NormSDist(BS_D2) End Function 'Used put-call parity theorem to price put option Function BS_PUT() As Double 29 BS_PUT = BS_Call - Me.txtBinomialS + _ (Me.txtBinomialX * Exp(-Me.txtBinomialr * Me.txtTimeT)) End Function

Recently Viewed Presentations

  • video slide - Houston Community College

    video slide - Houston Community College

    are the units of heredity, and are made up of segments of DNA. Genes are passed to the next generation through reproductive cells called . gametes (sperm and eggs) Each gene has a specific location called a . locus ....
  • Network Security and Privacy - Columbia University

    Network Security and Privacy - Columbia University

    Poison Ivy RAT downloaded from mincesur.com Previously used in Gh0stNet attacks Some attack domains were associated with "fast-flux" dynamic DNS providers Can rapidly change IP addresses to evade blacklisting www.usgoodluck.com, obama.servehttp.com, prc.dynamiclink.ddns.us But fast-flux DNS is commonly used by Russian...
  • Membership Workshop 2013 - MO PTA

    Membership Workshop 2013 - MO PTA

    Membership Workshop 2014 "A Guide for Success!" MO PTA. Basic Training Camp. 2014. The workshop today is designed to be a guide for membership officers or chairs of PTA units, as they plan and implement their membership campaign.
  • Title Slide - Maine Association of Student Financial Aid ...

    Title Slide - Maine Association of Student Financial Aid ...

    These are separate and distinct from a school's annual Title IV compliance audit and financial statement. Some servicers have failed to submit required audits. These servicers must submit a compliance audit to the Department no later than one fiscal year...
  • Using the planning system to enable community energy

    Using the planning system to enable community energy

    Genuine consent for a low-carbon future can only be secured through genuine engagement. Not through a D-A-D approach. I mentioned earlier that consultation that goes alongside the development of all types of local plan, but that it is usually less...
  • Making Maths fun - Curdworth

    Making Maths fun - Curdworth

    When do we teach maths? In Key Stages 1 and 2 your child is taught a one hour maths lesson every day, usually the first lesson of the day. Children in Reception class are also taught maths as a discreet...
  • THE MOVE TO VALUE: Provider and Patient Perspective

    THE MOVE TO VALUE: Provider and Patient Perspective

    Drill down on one aspect of MACRA- the bundled payment model . Evaluate the impact of episode-based bundled payment from the perspective of payer, provider, and patient. Illustrate the need to balance "big data" available to payers with "small data"...
  • Violence in the workplace K-12 - CUPE 411 | CUPE 411

    Violence in the workplace K-12 - CUPE 411 | CUPE 411

    Contact your CUPE Local for support. If incidents of workplace violence continue to happen, keep reporting every incident (even several times a day!)Remember you have a right to refuse unsafe work! 2. Parent/Community to Staff ... Violence in the workplace...