MS Access Forum / General 2 / September 2007
Modified McCauley Duration From VBA?
|
|
Thread rating:  |
(PeteCresswell) - 18 Sep 2007 00:16 GMT I tried posting this in ...Excel.Programming, but no luck...and I'm getting desperate - with a 16:30 deadline tomorrow for some proof-of-concept code. ---------------------------------------------------------- Typed into a cell, this works:
=MDURATION("1/1/2008", "1/1/2016", ".08", ".09", "2", "1")
But I want to invoke the calc from afar (specifically MS Access VBA).
I can instantiate a copy of Excel, and invoke other routines like "MIN", but am not having any luck with "MDURATION" and, indeed, it does not appear in the code completion dropdown for WorksheetFunction.mDuration
Sounds like I'm out of luck.
Or am I?
For the maschocistically inclined, here's the offending code (which looks it's best rendered in a monospaced font) - but all I really want to know is whether or not I can call MDURATION from VBA code and, if so, what the syntax would be....
-------------------------------------------------------------------------------------------------- Public Function MDURATION_Excel(ByVal theValues As String) As Variant 8000 debugStackPush mModuleName & ": MDURATION_Excel" 8001 On Error GoTo MDURATION_Excel_err
' PURPOSE: To invoke MS Excel's "MDURATION" (Modified McCauley duration) function" ' ACCEPTS: A list of values as a string delimintated by commas ' The values are: ' - Settlement Date ' - Maturity Date ' - Coupon percent ' - Yield percent ' - Payment Frequency ' 0 = 3./360 ' 1 = Actual/Actual ' 2 = Actual/360 ' 3 = Actual/365 ' 4 = European 30/360
' RETURNS: Result of Excel.MDURATION calculation ' ' SAMPLE: ' ----------------------------------------- ' MS Excel's Help e.g. ' =MDURATION("1/1/2008", "1/1/2016", ".08", ".09", "2", "1") ' 5.73567
' translated to call syntax for this routine: ' ?MDURATION_Excel("1/1/2008, 1/1/2016, .08, .09, 2, 1")
8002 Dim myArray() As String
Dim i As Long Dim myResult As Double
8003 If Len(theValues) > 0 Then 8010 If Excel_Start(gExcelApp) = True Then 8011 ParseToArrayOfString theValues, ",", myArray 'Put values in format acceptable to Excel 8912 myResult = gExcelApp.WorksheetFunction.mDuration(myArray) 8913 MDURATION_Excel = myResult 8919 End If 8990 Else 8991 MDURATION_Excel = "na" 8999 End If
MDURATION_Excel_xit: DebugStackPop On Error Resume Next Exit Function
MDURATION_Excel_err: BugAlert True, "" Resume MDURATION_Excel_xit End Function
Public Function ParseToArrayOfString(ByVal theStringToBeParsed As String, ByVal theDelimiter As String, ByRef theArray() As String) As Long 1000 debugStackPush mModuleName & ": ParseToArrayOfString" 1001 On Error GoTo ParseToArrayOfString_err
' PURPOSE: To parse a Delimited string into an array ' ACCEPTS: - String to be parsed ' - Delimiter between items in the string ' - Address of the array that results will be delivered to ' RETURNS: The number of items copied to the array or -1 ' SETS: The contents of the array specified ' ' CALLING CONVENTION: ' ReDim Items(20) ' ItemCount = ParseToArrayOfString("this, is, a string, delimited, by, commas",Items(),",")
1003 Dim P As Integer Dim i As Integer Dim newSize As Integer
Const textComparison = 1
1010 If Len(theStringToBeParsed & "") > 0 Then 1020 If theDelimiter = "" Then 'Check for valid theDelimiteriter 1030 ParseToArrayOfString = -1 1040 Else 1041 If Len(theStringToBeParsed) < 1 Then 1042 ParseToArrayOfString = -1 1043 Else 1050 i = 0 1060 P = InStr(1, theStringToBeParsed, theDelimiter, textComparison) 1061 If P = 0 Then 'Oops! Only one item, no delimiter 1062 i = 1 1063 ReDim Preserve theArray(i) 1064 theArray(0) = theStringToBeParsed 1065 Else 1070 Do While P > 0 'Copy all items except last 1080 newSize = i + 1 1090 ReDim Preserve theArray(newSize) 1100 theArray(LBound(theArray) + i) = Left$ (theStringToBeParsed, P - 1) 1110 i = i + 1 1120 theStringToBeParsed = Mid$(theStringToBeParsed, P + 1) 1130 P = InStr(1, theStringToBeParsed, theDelimiter, textComparison) 1140 Loop
1150 theArray(LBound(theArray) + i) = theStringToBeParsed 'Copy Last Item 1160 i = i + 1 1165 End If 1170 ParseToArrayOfString = i 1997 End If 1998 End If 1999 End If
ParseToArrayOfString_xit: DebugStackPop On Error Resume Next Exit Function
ParseToArrayOfString_err: ParseToArrayOfString = -1 BugAlert True, "" Resume ParseToArrayOfString_xit End Function
Public Function Excel_Start(ByRef theSS As Excel.Application) As Boolean 3000 debugStackPush mModuleName & ": Excel_Start: " 3001 On Error GoTo Excel_Start_err
' PURPOSE: - Start an instance of MS Excel or use an existing instance ' - Leave "theSS" pointing to the Excel Basic engine ' behind the newly-opened document ' ACCEPTS: - Pointer to the spreadsheet TB used by calling routine ' RETURNS: True/False depending on success ' ' NOTES: 1) We do not want to keep opening up new instances of Excel every time this routine ' is called, so we do the "= Nothing" check to see if theSS has already been set. ' OTHO the user may have closed that instance of Excel, leaving theSS pointing to ' Neverneverland. Experimentation shows that an error 2753 is generated in this case. ' Hence the error trap and the "userClosedExcel" switch. ' 'SAMPLE: ' ?SpreadSheetOpenExisting("D:\Dev\SEI\DataSource \BuySell.xls", gExcelApp)
3002 Dim userClosedExcel As Long Dim serverNotExist As Long Dim okToProceed As Boolean
Const oleError = 2753 Const rpcServerUnavailable = -2147023174 Const remoteServerNotExist = 462 Const docAlreadyOpen = 1004
Excel_Start_loop: ' --------------------------------------------------- ' Create an instance of Excel
3010 If (theSS Is Nothing) Or (userClosedExcel = 1) Then 3011 Set theSS = CreateObject("Excel.Application") '3012 With theSs '3013 .Workbooks.Add '3014 .ScreenUpdating = True '3015 .Visible = True '3016 End With 3019 End If
' --------------------------------------------------- ' Open up the spreadsheet
3999 Excel_Start = True
Excel_Start_xit: DebugStackPop On Error Resume Next Exit Function
Excel_Start_err: Select Case Err Case 2772 MsgBox "Unable to locate Microsoft Excel program. Please notify your administrator", 16, "Cannot Open MS Excel" Resume Excel_Start_xit Case oleError, rpcServerUnavailable If userClosedExcel = 0 Then userClosedExcel = userClosedExcel + 1 Resume Excel_Start_loop Else BugAlert True, "Unable to open MS Excel. Suspect user may have closed existing instance." Resume Excel_Start_xit End If Case remoteServerNotExist If serverNotExist = 0 Then serverNotExist = serverNotExist + 1 Set theSS = Nothing Resume Excel_Start_loop Else BugAlert True, "Unable to open MS Excel. Suspect user may have closed existing instance." Resume Excel_Start_xit End If
Case docAlreadyOpen BugAlert True, ""
Case Else BugAlert True, "" Resume Excel_Start_xit End Select Resume Excel_Start_xit 'Shouldn't be needed, but just in case..... End Function --------------------------------------------------------------------------------------------------
 Signature PeteCresswell
(PeteCresswell) - 18 Sep 2007 00:20 GMT Per (PeteCresswell):
>Sounds like I'm out of luck. > >Or am I? Also, I tried the obvious end run by opening up a .WorkSheet in my VBA code, pushing the MDURATION statement into a cell's .FormulaR1C1 and then trying to capture the cell's .Value to get my calculation result.
But I'm tripping over that too.
My code creates a statement like: =MDURATION("1/1/2008", "1/1/2016", ".08", ".09", "2", "1")
Which works fine if I capture it in an Immediate window and then paste it into an Excel spreadsheet that I've opened manually.
But when I programmatically put it into a spreadsheet I have opened via code, it gives an "Error 2029".
If I go one step further and copy the exact formula the code has created from the cell it was created into and paste that into another sheet, it works too.
Can anybody elucidate?
 Signature PeteCresswell
James A. Fortune - 18 Sep 2007 04:55 GMT > I tried posting this in ...Excel.Programming, but no luck...and > I'm getting desperate - with a 16:30 deadline tomorrow for some [quoted text clipped - 15 lines] > > Or am I? First try:
Excel.WorksheetFunction.MDURATION("1/1/86", "1/1/94", 0.08, 0.09, 2, 1)
after setting a reference to the Excel Object Library.
If that is not supported (I couldn't find the add-in on mine) then here is a rough start to an Access version:
'---Begin Module code--- Public Function MDuration(dtSettlement As Date, dtMaturity As Date, PercentCoupon As Double, PercentYield As Double, intTimesPerYear As Integer, intBasis As Integer) As Variant MDuration = Duration(dtSettlement, dtMaturity, PercentCoupon, PercentYield, intTimesPerYear, intBasis) / (1 + (PercentYield / intTimesPerYear)) End Function
Public Function Duration(dtSettlement As Variant, dtMaturity As Variant, PercentCoupon As Double, PercentYield As Double, intTimesPerYear As Integer, intBasis As Integer) As Variant Dim NPer As Integer Dim iPer As Integer Dim t As Double Dim dblPV As Double Dim dblPVtSum As Double Dim dblYield As Double
Duration = "#Num!" If Not IsDate(dtSettlement) Then Exit Function If Not IsDate(dtMaturity) Then Exit Function If PercentCoupon < 0 Then Exit Function If PercentYield < 0 Then Exit Function If intTimesPerYear <> 1 And intTimesPerYear <> 2 And intTimesPerYear <> 4 Then Exit Function If intBasis < 0 Or intBasis > 4 Then Exit Function If DateDiff("d", dtMaturity, dtSettlement) >= 0 Then Exit Function
'Basis is the type of day count basis to use.
'Basis Day count basis '0 or omitted US (NASD) 30/360 'I didn't make it Optional. You can. '1 Actual/actual '2 Actual/360 '3 Actual/365 '4 European 30 / 360
Select Case intBasis Case 0: 'This needs some date manipulation when start and end dates are on the 31st -> 1st of next month NPer = Round(DateDiff("d", dtSettlement, dtMaturity) * intTimesPerYear / 360#, 0) Case 1: 'Perhaps 365.25 is closer to what they had in mind, I used 365 + 1/4 - 1/100 + 1/400 NPer = Round(DateDiff("d", dtSettlement, dtMaturity) * intTimesPerYear / 365.2425, 0) Case 2: NPer = Round(DateDiff("d", dtSettlement, dtMaturity) * intTimesPerYear / 360#, 0) Case 3: NPer = Round(DateDiff("d", dtSettlement, dtMaturity) * intTimesPerYear / 365#, 0) Case 4: 'This needs some date manipulation when start and end dates are on the 31st -> 30th NPer = Round(DateDiff("d", dtSettlement, dtMaturity) * intTimesPerYear / 360#, 0) End Select dblPVtSum = 0 For iPer = 1 To NPer t = iPer / intTimesPerYear dblYield = PercentYield * 100 / intTimesPerYear If iPer <> NPer Then dblPV = dblYield / (1 + PercentYield / intTimesPerYear) ^ iPer Else dblPV = (dblYield + 100#) / (1 + PercentYield / intTimesPerYear) ^ iPer End If dblPVtSum = dblPVtSum + dblPV * t Next iPer dblPVtSum = dblPVtSum / 100# Duration = dblPVtSum End Function '----End Module code----
The Year Basis definitions I found are from:
http://www.codecogs.com/pages/standards/examples/example_3.htm
That coder, Alwyn Tan, simply calculates how many days are the year in question by seeing whether it is a leap year or not. I haven't given much thought yet as to the most accurate method. I hope this provides a starting point. It gave essentially the same numbers as the help file samples. I didn't do any testing beyond that.
James A. Fortune MPAPoster@FortuneJames.com
James A. Fortune - 18 Sep 2007 05:05 GMT > samples. I didn't do any testing beyond that. That's not quite true. I also used it on the example here:
http://www.finpipe.com/duration.htm
and got quite close to the same results. Also, I'm still not sure about how the 8 percent coupon in the Excel Help example fits in with everything. I just ignored it. Maybe one percentage is used to calculate the PV for the yield values and the other is used to calculate the PV for the $100.00 par value at the end, but that's only a guess.
James A. Fortune MPAPoster@FortuneJames.com
Tom Wickerath - 18 Sep 2007 09:56 GMT Hi Pete,
Does this work for you?
Option Compare Database Option Explicit
Public Function MDURATION_Excel _ (SettlementDate As String, _ MaturityDate As String, _ CouponPercent As Single, _ YieldPercent As Single, _ PaymentFrequency As Integer, _ FrequencyType As Integer) _ As Variant On Error GoTo ProcError
' PURPOSE: To invoke MS Excel's "MDURATION" ' (Modified McCauley duration) function" ' ACCEPTS: Two dates as strings & four numbers, comma delimited ' The values are: ' - Settlement Date ' - Maturity Date ' - Coupon percent ' - Yield percent ' - Payment Frequency ' 0 = 3./360 ' 1 = Actual/Actual ' 2 = Actual/360 ' 3 = Actual/365 ' 4 = European 30/360
' Example from Immediate Window ' ?MDURATION_Excel("1/1/2008", "1/1/2016", 0.08, 0.09, 2, 1) ' Result = 5.73566980400009
Dim xlApp As Excel.Application Dim xlBook As Excel.Workbook Dim ExcelRunning As Boolean
ExcelRunning = IsExcelRunning() If ExcelRunning Then Set xlApp = GetObject(, "Excel.Application") Else Set xlApp = CreateObject("Excel.Application") End If
Set xlBook = xlApp.Workbooks.Add()
xlApp.RegisterXLL xlApp.Application.LibraryPath & _ "\ANALYSIS\ANALYS32.XLL"
MDURATION_Excel = _ xlApp.Run("MDURATION", _ SettlementDate, MaturityDate, _ CouponPercent, YieldPercent, _ PaymentFrequency, FrequencyType) ExitProc: On Error Resume Next xlApp.ActiveWorkbook.Close Set xlBook = Nothing 'Release the workbook If Not ExcelRunning Then xlApp.Quit: Set xlApp = Nothing 'Release the application. End If Exit Function ProcError: MsgBox "Error " & Err.Number & ": " & Err.Description, _ vbCritical, "Error in MDURATION_Excel Function..." MDURATION_Excel = "na" Resume ExitProc End Function Function IsExcelRunning() As Boolean Dim xlApp As Excel.Application On Error Resume Next Set xlApp = GetObject(, "Excel.Application") IsExcelRunning = (Err.Number = 0) Set xlApp = Nothing Err.Clear End Function
Tom Wickerath Microsoft Access MVP https://mvp.support.microsoft.com/profile/Tom http://www.access.qbuilt.com/html/expert_contributors.html __________________________________________
> I tried posting this in ...Excel.Programming, but no luck...and > I'm getting desperate - with a 16:30 deadline tomorrow for some > proof-of-concept code. > ---------------------------------------------------------- <snip>
PeteCresswell - 18 Sep 2007 14:07 GMT Thanks James.
Thanks Tom.
Between the two of you, I think I'm going to be home free by COB. ------------------------------------------------------------------------ James: By some miracle, when I un-wrapped the code it worked right out of the box. Numbers are a little off vis-a-vis Excek, but that's just some digging on my part.
Tom: First I tried Application.Run with just .AddIns("Analysis ToolPak").Installed = True and, of course, it threw an error - something like "Macro not found".
Then I did it your way all the way with .RegisterXLL and it seemed to find the "MDURATION" macro - albeit returning an Error 2015.
Once I figure out what that means, I might be up and running via Excel. -----------------------------------------------------------------------
I'll put a couple hours into Tom's Excel route in hopes of not re- inventing the MDURATION wheel. If that doesn't work, I'll start tweaking James' code.
Again, my heartfelt thanks to you both!!!
Tom Wickerath - 18 Sep 2007 18:26 GMT Hi Pete,
Make sure you submit valid dates to the function. I was able to generate Error 2015 using this example, with an invalid date:
?MDURATION_Excel("1/1/2008l", "1/1/2016", 0.08, 0.09, 2, 1)
Tom Wickerath Microsoft Access MVP https://mvp.support.microsoft.com/profile/Tom http://www.access.qbuilt.com/html/expert_contributors.html __________________________________________
> Thanks James. > [quoted text clipped - 28 lines] > > Again, my heartfelt thanks to you both!!! (PeteCresswell) - 18 Sep 2007 19:01 GMT Per Tom Wickerath <AOS168b AT comcast DOT net>:
>Make sure you submit valid dates to the function. I was able to generate >Error 2015 using this example, with an invalid date: > >?MDURATION_Excel("1/1/2008l", "1/1/2016", 0.08, 0.09, 2, 1) Good catch. I also trapped out when I specified a maturity date that proceeded the settlement date..... but that's what error checking and validation are for.... -)
 Signature PeteCresswell
Tom Wickerath - 18 Sep 2007 19:14 GMT I forgot to mention that the Error 2015 was the return value from calling the function; my ProcError error handling code was never invoked.
Did you get my code to work without generating any errors? (It works on my PC, using Windows 2000 SP-4 with Access 2003 unpatched).
Tom Wickerath Microsoft Access MVP https://mvp.support.microsoft.com/profile/Tom http://www.access.qbuilt.com/html/expert_contributors.html __________________________________________
> Per Tom Wickerath <AOS168b AT comcast DOT net>: > >Make sure you submit valid dates to the function. I was able to generate [quoted text clipped - 5 lines] > that proceeded the settlement date..... but that's what error > checking and validation are for.... -) (PeteCresswell) - 19 Sep 2007 00:18 GMT Per Tom Wickerath <AOS168b AT comcast DOT net>:
>Did you get my code to work without generating any errors? (It works on my >PC, using Windows 2000 SP-4 with Access 2003 unpatched). Yes - for the nine bonds that I have in my little test harness.
MDURATION_Excel_TestHarness ---------------------------------------- 31331VAQ9 FFCB (callable: ne .0243032264963497 vs BB's 5.6170 Diff Days = -2013.0000000000000 Diff Percent = 366.67 3133XFLE4 FHLB?????????????? 2.49689940593026 vs BB's 2.4890 Diff Days = 3.0000000000000 Diff Percent = 000.33 3133XGDD3 FHLB 3.50499621512252 vs BB's 3.4980 Diff Days = 3.0000000000000 Diff Percent = 000.24 3134A4VB7 FHLMC 2.6161241458217 vs BB's 2.6080 Diff Days = 3.0000000000000 Diff Percent = 000.32 3134A4QD9 FHLMC 4.21480388584064 vs BB's 4.2070 Diff Days = 2.0000000000000 Diff Percent = 000.13 3137EAAX7 FHLMC 2.6972028317729 vs BB's 2.6800 Diff Days = 6.0000000000000 Diff Percent = 000.62 3137EAAF6 FHLMC 3.42743477098654 vs BB's 3.4190 Diff Days = 3.0000000000000 Diff Percent = 000.24 3134A4JT2 FHLMC 3.78515515390294 vs BB's 3.7770 Diff Days = 3.0000000000000 Diff Percent = 000.22 3128X5C48 FHLMC MTN 2.20757410517533 vs BB's 2.1990 Diff Days = 3.0000000000000 Diff Percent = 000.38 ----------------------------------------
The only real bad boy so far is a callable bond where I took a SWAG and plugged NextResetDate into MaturityDate.... to no apparent avail.
I'm now slogging through Bloomberg screens for about fifty more - dutifully capturing BB's view of each into a grid that I then Copy/Past into my test data table.
Once I get that populated, I'll clone the test harness and try the same thing on James' routine - just for grins.
 Signature PeteCresswell
(PeteCresswell) - 18 Sep 2007 19:05 GMT Per Tom Wickerath <AOS168b AT comcast DOT net>:
>I was able to generate I'm also getting rather large diffs from Bloomberg for some regular bonds and for callable bonds.
Once I survive the 16:30 meeting that's coming up, first thing I'll do is double check that we're feeding the same stuff to Bloomie and my little routine.
Then I think I'll play with James' code tonite and see what kind of diffs I come up with there - the hoped-for advantage being the ability to maybe deal with a wider range of possibilities than Excel's function can.
 Signature PeteCresswell
James A. Fortune - 18 Sep 2007 20:34 GMT > Thanks James. > [quoted text clipped - 5 lines] > By some miracle, when I un-wrapped the code it worked right out of > the box. Pete,
I believe in miracles, but I try not to make my code or inventions depend on them :-).
James A. Fortune MPAPoster@FortuneJames.com
Design your devices, and your life, for steady-state operation. -- Dr. Gil Wedekind
|
|
|