CODEWITHSUNDEEP
sqlms-accessvba
cheslijones
cheslijones

Reputation: 9194

MS Access VBA: Calculate Median without iterating through records

I am trying to find a quicker way to calculate my medians in Access. You can see the code below where it queries one item code at a time, sorts, and then calculates the median. Sometimes there are 600 item codes and those items can each have a 1000+ bases associated with it. The particular table I am working with has 150,000 total records for example and it is going really slow. Is there a better way to calculate each records median all at once as opposed to one item code at a time.

Function FIncPercentile(ByVal posCode As Single, ByVal k As Single, ByVal tbl As String) As Variant

Dim rstRec As Recordset
Dim db As Database
Dim n As Integer
Dim i As Single
Dim res, d1, d2 As Currency

' Create recordset from query
Set db = CurrentDb
Set rstRec = db.OpenRecordset("SELECT Co, Base " & _
                              "FROM " & tbl & " " & _
                              "WHERE Code = " & pos & " " & _
                              "ORDER BY Base ASC;")

' Skip if there are no matches
If IsNull(rstRec!base) Or rstRec.RecordCount = 0 Then
    FBasePercentile = Null
    Exit Function
End If

' Count records
rstRec.MoveLast
n = rstRec.RecordCount
rstRec.MoveFirst

' Calculate the index where k is the percentile
i = n * k

' Test the decimal and find value accordingly
If i = Int(i) Then
    rstRec.Move i - 1
    d1 = rstRec!base
    rstRec.MoveNext
    d2 = rstRec!base
    FIncPercentile = (d1 + d2) / 2
Else
    i = Round(i + 0.5, 0)
    rstRec.Move i - 1
    FIncPercentile = rstRec!base
End If

End Function

Upvotes: 0

Views: 1150

Answers (1)

dbmitch
dbmitch

Reputation: 5386

There is no Median function in Access. Excel has one but I believe it's limited to 30 numbers, so even if you wanted to try using an Automation function, I don't believe it would work for your case.

I think you may see a noticeable speed increase by fine tuning your function and by letting Microsoft's Jet Engine pre-compile your query.

  • Make sure you have the Base and Code fields indexed in your table(s)
  • Create a Parameter Query with Code having the criteria parameter [What Code]
  • Optimize your function with Recordset WITH construct, declared variables and matched field types (Code = Long Integer???)

Time it before and after all these changes and see if there's any noticeable difference

I corrected a couple typos that may not be typos - and I make an assumption that CODE is a long integer - which again I may be wrong. Also my changes are prefaced by '***************

CREATE Precompiled Parameter Query

Create New Query called "qdfPrepMedian"

Copy/Paste SQL >> PARAMETERS [What Code] Long; SELECT Co, Base FROM <YourTableName> WHERE Code = [What Code] ORDER BY Base ASC;

Save the query

Adjusted Function

Option Explicit

'***********************
' changed posCode to Long
'***********************
Function FIncPercentile(ByVal posCode As Long, ByVal k As Single, ByVal tbl As String) As Variant

    '***********************
    ' CREATE/USE Precompiled Parameter Query
    ' Create New Query called "qdfPrepMedian"
    ' Copy/Paste SQL >> PARAMETERS [What Code] Long; SELECT Co, Base FROM <YourTableName> WHERE Code = [What Code] ORDER BY Base ASC;

    Const QRY_BY_CODES  As String = "qdfPrepMedian"

    Dim qdf     As QueryDef
    '
    '***********************

    Dim rstRec  As Recordset
    Dim db      As Database
    Dim n       As Integer
    Dim i       As Single

    ' Declare all Currency variables on separate lines
    ' Otherwise they will be variants
    Dim res     As Currency
    Dim d1      As Currency
    Dim d2      As Currency

    Set db = CurrentDb

    '***********************
    ' Create readonly recordset from querydef
    Set qdf = db.QueryDefs(QRY_BY_CODES)
    qdf.Parameters("What Code") = posCode ' matches LONG variable passed to function
    Set rstRec = qdf.OpenRecordset(dbOpenSnapshot, dbReadOnly) ' Readonly is sometimes faster
    '***********************

    ' Use WITH rstRec
    With rstRec

        ' Skip if there are no matches
        If IsNull(!base) Or .RecordCount = 0 Then
        '*** Is this a type ***
        '    FBasePercentile = Null
        ' Should it BE
            FIncPercentile = Null
            Exit Function
        End If

        ' Count records
        .MoveLast
        n = .RecordCount
        .MoveFirst

        ' Calculate the index where k is the percentile
        i = n * k

        ' Test the decimal and find value accordingly
        If i = Int(i) Then
            .Move i - 1
            d1 = !base
            .MoveNext
            d2 = !base
            FIncPercentile = (d1 + d2) / 2
        Else
            i = Round(i + 0.5, 0)
            .Move i - 1
            FIncPercentile = !base
        End If

    End With

End Function

Upvotes: 2

Related Questions