MS Access VBA: Calculate Median without iterating through records - sql

Question

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

Answer 1

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