MCount - Faster than DCount?

Mile-O

Mile-O

Back once again...
Local time
Today, 18:41
Joined
Dec 10, 2002
Messages
11,316
Can somebody test my new MCount() function?

I got annoyed at the time DCount() was taking on a few of my queries so decided to try creating my own version.

It's DAO so, a reference must be set if there isn't one as default.

My initial tests have it being about 1 second faster than DCount - that's without criteria which I haven't included yet.

It won't work with queries that ask the user for a parameter but it can refer to a form.

Code: 
Public Function MCount(strField As String, strTable As String, Optional strCriteria As String) As Long
    
    On Error GoTo Err_MCount
    
    Dim qdf As DAO.QueryDef
    Dim rs As DAO.Recordset
    Dim rsTemp As DAO.Recordset
    Dim strParams() As String
    Dim intCounter As Integer
    Dim strForm As String
    Dim strControl As String
    Dim intPosition As Integer
    
    Set qdf = DBEngine(0)(0).QueryDefs(strTable)
        
    If qdf.Parameters.Count <> 0 Then
        For intCounter = 0 To qdf.Parameters.Count - 1
            ReDim Preserve strParams(intCounter)
            strParams(intCounter) = Mid(qdf.Parameters(intCounter).Name, 9)
        Next intCounter
        For intCounter = LBound(strParams()) To UBound(strParams())
            intPosition = InStr(strParams(intCounter), "!")
            strForm = Left(strParams(intCounter), intPosition - 1)
            strControl = Mid(strParams(intCounter), intPosition + 1)
            qdf.Parameters(intCounter) = Forms(strForm)(strControl)
        Next intCounter
    End If

    Set rs = qdf.OpenRecordset

    If rs.EOF Then
        MCount = 0
    Else
        Set rsTemp = rs
        rsTemp.Filter = strCriteria
        Set rsTemp = rs.OpenRecordset
        rsTemp.MoveLast
        MCount = rsTemp.RecordCount
    End If
    
Exit_MCount:
    Set qdf = Nothing
    Set rs = Nothing
    Set rsTemp = Nothing
    Exit Function
    
Err_MCount:
    MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
    Resume Exit_MCount
    
End Function
 
Last edited:
i've tried it on a query with about 8000 records ... your MCount proved faster than DCount ... good job ;)
 
Excellent. Now all I need to do is get it to work with criteria. :eek:
 
I've fixed the code and it should now work with criteria unless there are some unknown factors I haven't included.

It's averaging around 1.1 seconds faster the DCount.

Now to make MMax(), MMin(), MAvg(), and MLookup(), etc. :D
 
MLookup(), like MCount(), is averaging 1.1 seconds faster than DLookup(). :cool:

Code: 
Public Function MLookup(strField As String, strTable As String, Optional strCriteria As String) As Variant
    
    On Error GoTo Err_MLookup
    
    Dim qdf As DAO.QueryDef
    Dim rs As DAO.Recordset
    Dim rsTemp As DAO.Recordset
    Dim strParams() As String
    Dim intCounter As Integer
    Dim strForm As String
    Dim strControl As String
    Dim intPosition As Integer
    
    Set qdf = DBEngine(0)(0).QueryDefs(strTable)
    
    If qdf.Parameters.Count <> 0 Then
        For intCounter = 0 To qdf.Parameters.Count - 1
            ReDim Preserve strParams(intCounter)
            strParams(intCounter) = Mid(qdf.Parameters(intCounter).Name, 9)
        Next intCounter
        For intCounter = LBound(strParams()) To UBound(strParams())
            intPosition = InStr(strParams(intCounter), "!")
            strForm = Left(strParams(intCounter), intPosition - 1)
            strControl = Mid(strParams(intCounter), intPosition + 1)
            qdf.Parameters(intCounter) = Forms(strForm)(strControl)
        Next intCounter
    End If
    
    Set rs = qdf.OpenRecordset
    
    If rs.EOF Then
        MLookup = Null
    Else
        Set rsTemp = rs
        rsTemp.Filter = strCriteria
        Set rsTemp = rs.OpenRecordset
        MLookup = rsTemp(strField)
    End If
    
Exit_MLookup:
    Set qdf = Nothing
    Set rs = Nothing
    Set rsTemp = Nothing
    Exit Function
    
Err_MLookup:
    MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
    Resume Exit_MLookup

End Function
 
hmm, you're doing good ... maybe one day you'll be doing your version of Milo Access as well :D
 
The MMin() function - 1.1 seconds faster than DMin() :cool:

Code: 
Public Function MMin(strField As String, strTable As String, Optional strCriteria As String) As Variant

    On Error GoTo Err_MMin

    Dim qdf As DAO.QueryDef
    Dim rs As DAO.Recordset
    Dim rsTemp As DAO.Recordset
    Dim strParams() As String
    Dim intCounter As Integer
    Dim strForm As String
    Dim strControl As String
    Dim intPosition As Integer
    
    Set qdf = DBEngine(0)(0).QueryDefs(strTable)
    
    If qdf.Parameters.Count <> 0 Then
        For intCounter = 0 To qdf.Parameters.Count - 1
            ReDim Preserve strParams(intCounter)
            strParams(intCounter) = Mid(qdf.Parameters(intCounter).Name, 9)
        Next intCounter
        For intCounter = LBound(strParams()) To UBound(strParams())
            intPosition = InStr(strParams(intCounter), "!")
            strForm = Left(strParams(intCounter), intPosition - 1)
            strControl = Mid(strParams(intCounter), intPosition + 1)
            qdf.Parameters(intCounter) = Forms(strForm)(strControl)
        Next intCounter
    End If
    
    Set rs = qdf.OpenRecordset
    
    If rs.EOF Then
        MMin = Null
    Else
        Set rsTemp = rs
        rsTemp.Filter = strCriteria
        rsTemp.Sort = strField
        Set rsTemp = rs.OpenRecordset
        MMin = rsTemp(strField)
    End If
    
Exit_MMin:
    Set qdf = Nothing
    Set rs = Nothing
    Set rsTemp = Nothing
    Exit Function
    
Err_MMin:
    MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
    Resume Exit_MMin

End Function
 
And the MMax() function - likewise:

Code: 
Public Function MMax(strField As String, strTable As String, Optional strCriteria As String) As Variant

    On Error GoTo Err_MMax

    Dim qdf As DAO.QueryDef
    Dim rs As DAO.Recordset
    Dim rsTemp As DAO.Recordset
    Dim strParams() As String
    Dim intCounter As Integer
    Dim strForm As String
    Dim strControl As String
    Dim intPosition As Integer
    
    Set qdf = DBEngine(0)(0).QueryDefs(strTable)
    
    If qdf.Parameters.Count <> 0 Then
        For intCounter = 0 To qdf.Parameters.Count - 1
            ReDim Preserve strParams(intCounter)
            strParams(intCounter) = Mid(qdf.Parameters(intCounter).Name, 9)
        Next intCounter
        For intCounter = LBound(strParams()) To UBound(strParams())
            intPosition = InStr(strParams(intCounter), "!")
            strForm = Left(strParams(intCounter), intPosition - 1)
            strControl = Mid(strParams(intCounter), intPosition + 1)
            qdf.Parameters(intCounter) = Forms(strForm)(strControl)
        Next intCounter
    End If
    
    Set rs = qdf.OpenRecordset
    
    If rs.EOF Then
        MMax = Null
    Else
        Set rsTemp = rs
        rsTemp.Filter = strCriteria
        rsTemp.Sort = strField & " DESC"
        Set rsTemp = rs.OpenRecordset
        MMax = rsTemp(strField)
    End If
    
Exit_MMax:
    Set qdf = Nothing
    Set rs = Nothing
    Set rsTemp = Nothing
    Exit Function
    
Err_MMax:
    MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
    Resume Exit_MMax

End Function
 
Mile, don't know if this would interest you, but I recalled that on the Access web someone had previously created replacements for the DLookup, DCount, DSum, DMax & DMin functions. Here is the link: Domain Aggregate Functions Replacements

I quickly looked at the code, and it is also in DAO. The programmer (Trevor Best) seemed to emphasize that the built-in Access functions were slow on attached tables, so perhaps that was his primary focus.
 
Just looked at it now. It builds SQL statements like:

SELECT Count(*) FROM
SELECT Max()

etc.

but if a query has parameters then they won't work because you'll get the Too few parameters: Expected x message. Mine's takes the parameters into account.
 
I didn't really look too closely at the code. Just thought there might be something of interest in there for you. Oh well.

Mine's
Click to expand...
?
 
I'm actually testing these on linked tables too. :)

Unfortunately I can't get the MSum and MAvg faster the DSum and DAvg - I'm about 120 milliseconds slower. :mad:

I'm open to suggestions...
 
Well, if you posted your current code we might be able to help you optimize it.

Until then ill look for any tricks i can.
 
ReAn said:
Well, if you posted your current code we might be able to help you optimize it.
Click to expand...

HEre's what I've got with respect to MSum: :confused:

Code: 
Public Function MSum(ByRef strField As String, ByRef strTable As String, Optional ByRef strCriteria As String) As Long

    On Error GoTo Err_MSum

    Dim qdf As DAO.QueryDef
    Dim rs As DAO.Recordset
    Dim rsTemp As DAO.Recordset
    Dim strParams() As String
    Dim intCounter As Integer
    Dim strForm As String
    Dim strControl As String
    Dim intPosition As Integer
    
    Set qdf = DBEngine(0)(0).QueryDefs(strTable)
    
    If qdf.Parameters.Count <> 0 Then
        For intCounter = 0 To qdf.Parameters.Count - 1
            ReDim Preserve strParams(intCounter)
            strParams(intCounter) = Mid(qdf.Parameters(intCounter).Name, 9)
        Next intCounter
        For intCounter = LBound(strParams()) To UBound(strParams())
            intPosition = InStr(strParams(intCounter), "!")
            strForm = Left(strParams(intCounter), intPosition - 1)
            strControl = Mid(strParams(intCounter), intPosition + 1)
            qdf.Parameters(intCounter) = Forms(strForm)(strControl)
        Next intCounter
    End If
    
    Set rs = qdf.OpenRecordset
    
    If rs.EOF Then
        MSum = Null
    Else
        Set rsTemp = rs
        rsTemp.Filter = strCriteria
        Set rsTemp = rsTemp.OpenRecordset
        With rsTemp
            Do While Not .EOF
                If .Fields(strField) <> 0 Then
                    MSum = MSum + .Fields(strField)
                End If
                .MoveNext
            Loop
        End With
    End If
    
Exit_MSum:
    Set qdf = Nothing
    Set rs = Nothing
    Set rsTemp = Nothing
    Exit Function
    
Err_MSum:
    MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
    Resume Exit_MSum

End Function
 
Hrm, looks interesting... Tried SQL Appregation combined with your domain appregation? might work... otherwise I cannot think of anything.
 
I tried counting a 150,000 row linked table (both db's are located on my C drive). What I found was that the order in which they ran had an impact. If I ran DCount() first, it would take 8 seconds, Mcount() running first would take 6 sec and the following two would take under 1 sec but running the Count(*) aggregate query first did not affect the time, it always ran in under a second.

What this tells me is that both DCount() and MCount() need to load the table to count it and DCount() takes 30% longer to do it. Count(*) does NOT need to load the table to count it as long as you don't use any selection criteria. It obtains the count by reading the table stats. That's why its timing is consistant.
 
Thanks Pat. The search continues. :(
 
Mile: Make functions in VB6, compile to DLL, reference DLL.

This way, your code is compiled, so it will run much faster than through access (aka interpreted).

Give it a try see what happens.
 
That's what I'm thinking of doing.

I started compiling a list a functions I've written so that I can put them into one big .dll and call them whenever I want.

As you can tell from the formula in the WaterCooler I've started writing every function I can think of and other that I can find. I'm also looking through all the formulas in Excel 2002 to learn all the financial, statistical, mathematical functions etc. that Accesd doesn't support and recreating them.

I'll give it a shot after I've finished trying to make my Glowbox ActiveX Control. :rolleyes:
 
You must log in or register to reply here.

Similar threads

A
Restrictions Update Message
Replies
17
Views
324
Gasman
Gasman
N
How to ensure the open recordset include also any new record entered
Replies
9
Views
294
nector
N
N
VBA MS Access Error Handling
Replies
5
Views
365
Pat Hartman
P
N
Solved How to grab the last updated record in a table
Replies
10
Views
380
June7
June7
N
Solved Cleaning Up the recordset after use in MS Access
Replies
7
Views
692
gemma-the-husky
gemma-the-husky

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom