CODEWITHSUNDEEP
vbaexcelms-access
Nishith
Nishith

Reputation: 49

Calling MS Excel function from MS Access VBA

I am working an MS Access application a part of which uses Beta Distribution function. Since MS Access does not have Beta Distribution function of its own I'm using calling BetaDist function from MS Excel. I've tested the code in MS Excel and it seems to run successfully. In MS Access also the code is working fine and generating correct results but the time taken by Access is very high than the time taken by Excel. I'm posting the part of code which utilizes BetaDist function and also the slowest portion of the code. I want to reduce the time taken by Access. Any help is appreciated.

Part of Code which utilizes BetaDist:

    For i = 1 To UBound(arrBetaParam)
       If arrBetaParam(i).Alpha <= 0 Or arrBetaParam(i).Beta <= 0 Or tryOutValue > arrBetaParam(i).ExpValue Then
        dblTempEP = 0
       Else
            If tryOutValue > arrBetaParam(i).LastKnownGoodValue Then
                dblTempEP = 0
            Else
                dblTempEP = 1
            End If
            Dim bt As Double
            bt = -1
            On Error Resume Next
            bt = Excel.WorksheetFunction.BetaDist(tryOutValue, arrBetaParam(i).Alpha, arrBetaParam(i).Beta, 0, arrBetaParam(i).ExpValue)
            tj = bt
            If bt > -1 Then
                If bt > 1 Then bt = 1
                If bt < 0 Then bt = 0
                arrBetaParam(i).LastKnownGoodValue = tryOutValue
                dblTempEP = 1 - bt
            End If
            On Error GoTo 0
        End If

        OEP = OEP + dblTempEP * arrBetaParam(i).Rate
        'sumRate = sumRate + arrBetaParam(i).Rate
    Next

Upvotes: 1

Views: 1134

Answers (2)

Gustav
Gustav

Reputation: 55806

You could do like this:

Dim xls As Excel.Application    
Set xls = New Excel.Application

' Begin loop.
    bt = xls.WorksheetFunction.BetaDist(tryOutValue, arrBetaParam(i).Alpha, arrBetaParam(i).Beta, 0, arrBetaParam(i).ExpValue)
' End loop.  

xls.Quit
Set xls = Nothing

Upvotes: 1

AnalystCave.com
AnalystCave.com

Reputation: 4974

Your code is probably taking so long due to the fact it has to open the Excel application.

BetaDist is not complicated to implement. Why not create a VBA function in Acces VBA. Here is the formula:

f(x) = B(alpha,beta)-1 xalpha-1(1-x)beta-1

Here I found a decent implementation. Didn't test it though:

Option Explicit

Const n             As Long = 200    ' increase for accuracy, decrease for speed

Public aa           As Double
Public bb           As Double

Function BetaDist1(x As Double, a As Double, b As Double)
    Dim d1          As Double
    Dim d2          As Double
    Dim n1          As Long
    Dim n2          As Long

    aa = a
    bb = b
    n1 = x * n
    n2 = n - n1

    d1 = SimpsonInt(0, x, n1)
    d2 = SimpsonInt(x, 1, n2)
    BetaDist1 = d1 / (d1 + d2)
End Function

Function SimpsonInt(ti As Double, tf As Double, ByVal n As Long) As Double
    ' shg 2006

    ' Returns the integral of Func (below) from ti to tf _
      using Composite Simpson's Rule over n intervals
    Dim i           As Double  ' index
    Dim dH          As Double  ' step size
    Dim dOdd        As Double  ' sum of Func(i), i = 1, 3, 5, 7, ... n-1, i.e., n/2 values
    Dim dEvn        As Double  ' sum of Func(i), i =   2, 4, 6,  ... n-2  i.e., n/2 - 1 values
    ' 1 + (n/2) + (n/2 - 1) + 1 = n+1 function evaluations

    If n < 1 Then Exit Function

    If n And 1 Then n = n + 1    ' n must be even
    dH = (tf - ti) / n

    For i = 1 To n - 1 Step 2
        dOdd = dOdd + Func(ti + i * dH)
    Next i

    For i = 2 To n - 2 Step 2
        dEvn = dEvn + Func(ti + i * dH)
    Next i

    SimpsonInt = (Func(ti) + 4# * dOdd + 2# * dEvn + Func(tf)) * dH / 3#    ' weighted sum
End Function

Function Func(t As Double) As Double
    Func = t ^ (aa - 1) * (1 - t) ^ (bb - 1)
End Function

Upvotes: 2

Related Questions