Home | Contact Us | FAQ | Search & Site Map | Link to Us
Sign In | Join | Other 45 Sites in Network
Home
Discussion GroupsFormsForms ProgrammingQueriesModules / DAO / VBAReports / PrintingMacrosDatabase DesignSecurityConversionImporting / LinkingSQL Server / ADPMultiuser / NetworkingReplicationSetup / ConfigurationDeveloper ToolkitsActiveX ControlsNew UsersGeneral 1General 2
Access DirectoryToolsTutorialsUser Groups
Related Topics
SQL ServerOther DB ProductsMS OfficeMore Topics ...

MS Access Forum / General 2 / September 2007

Tip: Looking for answers? Try searching our database.

Modified McCauley Duration From VBA?

Thread view: 
Enable EMail Alerts  Start New Thread
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
 
Sign In
Join
My Latest Posts
My Monitored Threads
My Blog
My Photo Gallery
My Profile
My Homepage

Start New Thread
Enable EMail Alerts
Rate this Thread



©2009 Advenet LLC   Privacy Policy - Terms of Use
This website includes both content owned or controlled by Advenet as well as content owned or controlled by third parties.