We help IT Professionals succeed at work.

Processing large number of records in Access 2003 take to long...

mmcs2k8 asked
Last Modified: 2013-11-27
I have an application that is processing a large Access database (tables are external of program).  The routine in question was originally using ADO LIB 2.1 connections and recordsets.  I rewrote the logic to use .GetRows and then load the resulting recordsets into arrays.   I then close the recordset objects and process against the arrays.  I also added a BeginTrans and CommitTrans where a record gets added to a different recordset.

I really thought I would see at least some performance gain by eliminating the need for connection time by using arrRST and arrRST2 instead of objRST and objRST2.  There were no noticeable gains by going to this concept.

I have identified the speed issue to my inner most loop (arrRST2) as exampled in the attached code snippet.
Public Function fn_InventoryBOMProductionFooter(strProductCode As String, lngJobNumber As Single, intQuantity As Double, intLevel As Integer, strHeader As String, strFooter As String, strReportFooter As String, intTopLevel As Integer)
''drs -----------------------------------------------------------------------------------
''    Added array processes to replace the recordsets objRST and objRST2.  This was done to reduce
''    the ADO connection time required while executing this function.  arrRST is objRST (header).
''    arrRST2 is objRST2 (footer).  The arrays are loaded using objCN.GetRows.  A param array is
''    used to specify to .GetRows which fields to retrieve into the arrays.  The
''    constants defined are ordinals based on the order of the fields as specified in the param arrays.
''    Remember, the arrays in this function are Option Base 0
''drs -----------------------------------------------------------------------------------
    On Error GoTo error_:
    ' Check to see if the item was upgraded.
    Dim dbs As Database
    Dim qdf As QueryDef
    Dim rst As Recordset
    Dim rstIC As Recordset
    Dim strChildCode As String
    Dim dblLSTC As Double
    Dim strDesc As String
    Dim dblUOM As Double
    Dim strRevision As String
    Dim strWCCode As String
    Dim blnKanban As Boolean
    Dim param As Parameter
    Dim dblBuildQty As Double
    Dim intCount As Integer
''drs    Dim intTotal As Integer
''drs - Added - Ordinal assignments for arrRST (objRST Recordset)
    Const cstJobNumber    As Integer = 0
    Const cstParentCode   As Integer = 1
    Const cstRSTQty       As Integer = 2
''drs - Added - Ordinal assignments for arrRST2 (objRST2 Recordset)
    Const cstChildCode    As Integer = 0
    Const cstLSTC         As Integer = 1
    Const cstDescription  As Integer = 2
    Const cstUM           As Integer = 3
    Const cstRevLvl       As Integer = 4
    Const cstWCCode       As Integer = 5
    Const cstKanbanFlag   As Integer = 6
    Const cstRST2Qty      As Integer = 7
    Const cstDesignation  As Integer = 8
    Const cstNotes        As Integer = 9
    Const cstSeqNum       As Integer = 10
''drs - arrays, record pointers and counts for arrRST (objRST) and arrRST2 (objRST2)
    Dim arrRST()          As Variant
    Dim arrRST2()         As Variant
    Dim intRSTPntr        As Integer
    Dim intRST2Pntr       As Integer
    Dim intRSTCnt         As Integer
    Dim intRST2Cnt        As Integer
'Other Variables
    Dim objCN   As New ADODB.Connection
    Dim objRST1 As New ADODB.Recordset
''drs - changed from as New... to As....
    Dim objRST  As ADODB.Recordset
    Dim objRST2 As ADODB.Recordset
    Dim strSQL  As String
    Set dbs = CurrentDb()
    'Set rstIC = dbs.OpenRecordset("Inventory", dbOpenDynaset)
    Set rstIC = dbs.OpenRecordset("SELECT [ProdCode], [MakeBuyStk] FROM Inventory", dbOpenDynaset)
    'Open the connection
    Set objCN = CurrentProject.Connection
    If intLevel = 1 Then
        'Retrieve the parent code and the quantity for the first level
        strSQL = "SELECT t1.JobNumber,t1.ProductCode as ParentCode,t1.Quantity " & _
            " FROM " & strHeader & " t1 " & _
            " WHERE JobNumber = " & lngJobNumber & _
            " AND LTRIM(RTRIM(productcode)) = '" & strProductCode & "'" & _
            " ORDER BY t1.ProductCode "
        'Retrieve the parent code and the quantity for second level onwards
        strSQL = "SELECT t1.JobNumber,t1.ChildCode as ParentCode,t1.Quantity, t1.SequenceNum " & _
            " FROM " & strFooter & " t1 " & _
            " WHERE level = " & intLevel - 1 & _
            " AND JobNumber = " & lngJobNumber & _
            " ORDER BY t1.ChildCode "
    End If
''drs - Connection direct to reduce db overhead
''drs - Load arrRST with objRST to decrease connection load
On Error Resume Next
    Set objRST = objCN.Execute(strSQL)
    arrRST = objRST.GetRows(, , Array("JobNumber", "Parentcode", "Quantity"))
    If objRST.BOF And objRST.EOF Then
      intLevel = intTopLevel
      GoTo cleanhouse_
    End If
    Set objRST = Nothing
    intRSTCnt = UBound(arrRST, 2)
    intCount = 1
On Error GoTo error_
''drs - Replaced objRST references with arrRST(fldconstant,recpntr)
''drs - Loop arrRST (objRST)
    For intRSTPntr = 0 To intRSTCnt
        DoCmd.Echo True, "Adding item " & intRSTPntr + 1 & " of " & intRSTCnt & " for Level " & intLevel & " of " & intTopLevel ''intCount & " of " & intRSTCnt & " for Level " & intLevel & " of " & intTopLevel
        lngJobNumber = Val(field2str(arrRST(cstJobNumber, intRSTPntr)))
        strProductCode = LTrim(RTrim(field2str(arrRST(cstParentCode, intRSTPntr))))
        intQuantity = Val(field2str(arrRST(cstRSTQty, intRSTPntr)))
        'intQuantity = Val(field2str(intQuantity))
'            If intLevel = 1 Then
'                'Delete any records for the current production code if they exist in the
'                'footer table
'                strSQL = "DELETE FROM " & strFooter & _
'                    " WHERE JobNumber = " & lngJobNumber
'                objCN.Execute strSQL
'            End If
        'Loop through the inventoryBOM table to generate data into the footer table
        'Update this statement.
''drs - Connection direct to reduce db overhead
''drs - Load arrRST2 with objRST2 to further decrease connection load
        strSQL = "SELECT InventoryBOM.*, Inventory.LSTC, Inventory.UM " & _
                " FROM InventoryBOM INNER JOIN Inventory ON InventoryBOM.ChildCode = Inventory.ProdCode " & _
                " WHERE ltrim(rtrim(ParentCode)) = '" & strProductCode & "'" & _
                " ORDER BY ChildCode "
On Error Resume Next
        ReDim arrRST2(0, 0)
        Set objRST2 = objCN.Execute(strSQL)
        arrRST2 = objRST2.GetRows(, , Array("ChildCode", "LSTC", "Description", "UM", "RevisionLevel", "WCCode", _
                                            "KanbanFlag", "Quantity", "Designation", "Notes", "SequenceNum"))
        intRST2Cnt = UBound(arrRST2, 2)
        Set objRST2 = Nothing
''drs - debug On Error GoTo error_
        If strReportFooter <> "Report" Then
'                Set qdf = dbs.QueryDefs("qryICJobOrdersUpgrades")
'               qdf.Parameters(0) = [Forms]![frmICInventoryBOMJobHeader]![SalesOrderNumber]
'               qdf.Parameters(1) = [Forms]![frmICInventoryBOMJobHeader]![dblSortOrder]
''                For Each param In qdf.Parameters
''                    param.Value = Eval(param.Name)
''                Next param
'                Set rst = qdf.OpenRecordset()
        End If
'            If DLookup("[MakeBuyStk]", "Inventory", "[ProdCode]='" & strProductCode & "'") = "Stock" And intLevel <> 1 Then
        If intLevel <> 1 Then
            If strReportFooter = "Report" Then
                ' Printing the report.
                If [Forms]![frmICInventoryBOMPrint]![grpOptions] <> 3 Then
                    GoTo AddBOM
                End If
                'rstIC.FindFirst "[ProdCode]= '" & strProductCode & "' And  [MakeBuyStk] = 'Buy' "
                rstIC.FindFirst "[ProdCode]= '" & strProductCode & "'"
                'rstIC.FindFirst "[ProdCode]= '" & strProductCode & "' And  [MakeBuyStk] <> 'Stock'"
                rstIC.FindFirst "[ProdCode]= '" & strProductCode & "'"
            End If
            If rstIC.NoMatch = True Then
                ' Do nothing. We do not want to build this sub-assembly. Because it has already been built.
                ' We dont want to build any sub-assembly that is higer than a level 1.
''drs - Replaced objRST2 references with arrRST2(fieldconstant,recordpointer)
''drs - Loop arrRST2 (objRST2)
                For intRST2Pntr = 0 To intRST2Cnt
                        'DoCmd.Echo True, "Adding item " & intCount & " of " & intRSTCnt
                    If strReportFooter = "Report" Then
                        'rst.FindFirst "[MainItem]='" & strProductCode & "' and [ReplacedPart]='" & field2str(objRST2![ChildCode]) & "'"
                        ' If no upgrade is found.
                        strChildCode = field2str(arrRST2(cstChildCode, intRST2Pntr))
                        dblLSTC = arrRST2(cstLSTC, intRST2Pntr)
                        strDesc = Nz(arrRST2(cstDescription, intRST2Pntr), "")
                        'dblUOM = objRST2![UOMConvert]
                        ' Lookup the UOM
                        dblUOM = Nz(DLookup("[UOM Convert]", "Inventory Units of Measure", "[UOM]='" & arrRST2(cstUM, intRST2Pntr) & "'"), 1)
                        strRevision = Nz(arrRST2(cstRevLvl, intRST2Pntr), "")
                        strWCCode = Nz(arrRST2(cstWCCode, intRST2Pntr), "")
                        blnKanban = arrRST2(cstKanbanFlag, intRST2Pntr)
''drs If field2str(arrRST2(cstChildCode, intRST2Pntr)) = "TRS-SNA-286" Then
''End If
                        strChildCode = field2str(arrRST2(cstChildCode, intRST2Pntr))
                        dblLSTC = arrRST2(cstLSTC, intRST2Pntr)
                        strDesc = Nz(arrRST2(cstDescription, intRST2Pntr), "")
                        dblUOM = Nz(DLookup("[UOM Convert]", "Inventory Units of Measure", "[UOM]='" & arrRST2(cstUM, intRST2Pntr) & "'"), 1)
                        strRevision = Nz(arrRST2(cstRevLvl, intRST2Pntr), "")
                        strWCCode = Nz(arrRST2(cstWCCode, intRST2Pntr), "")
                        blnKanban = arrRST2(cstKanbanFlag, intRST2Pntr)
                    End If
''drs - changed objRST1 to With... End With
                    strSQL = "SELECT * " & _
                             " FROM " & strFooter & " t1 " & _
                             " WHERE JobNumber = " & lngJobNumber
                    With objRST1
                        If .State <> 1 Then
                          .OPEN strSQL, objCN, adOpenDynamic, adLockOptimistic
                        End If
                            !JobNumber = lngJobNumber
                            !Parentcode = strProductCode
                            !ChildCode = strChildCode
                            !quantity = intQuantity * Val(field2str(arrRST2(cstRST2Qty, intRST2Pntr)))
                            'update the WIP
                            ![QtyUsed] = intQuantity * Val(field2str(arrRST2(cstRST2Qty, intRST2Pntr)))
                            !Level = intLevel
                            ![Description] = strDesc
                            If strRevision <> "" Then
                                ![Revision] = strRevision
                            End If
                            ' Set the UOM = 1 if it happens to be 0 in the Inventory Units of Measure table.
                            ![UOMConvert] = IIf(dblUOM = 0, 1, dblUOM)
                            ![UnitCost] = dblLSTC
                            ![WCCode] = strWCCode
                            ![Designation] = arrRST2(cstDesignation, intRST2Pntr)
                            ![Notes] = arrRST2(cstNotes, intRST2Pntr)
                            ![KanbanFlag] = blnKanban
                            ![SequenceNum] = arrRST2(cstSeqNum, intRST2Pntr)
                            ![CreatedBy] = CurrentUser()
                            ![BOMQuantity] = Val(field2str(arrRST2(cstRST2Qty, intRST2Pntr)))
''drs - debug IF
                            If Right(strFooter, 4) = "temp" Then
                              ![Modified] = Now()
                              ![ModifiedBy] = CurrentUser()
                            End If
                    End With
                Next intRST2Pntr
            End If
            GoTo AddBOM
        End If
    Next intRSTPntr
''drs - Release arrays
    ReDim arrRST(0, 0)
    ReDim arrRST2(0, 0)
    ' Close recordsets and deallocate memory space.
''drs set on error to allow house cleaning processes
On Error Resume Next
    If objRST.State = 1 Then
    End If
    Set objRST = Nothing
    If objRST1.State = 1 Then
    End If
    Set objRST1 = Nothing
    If objRST2.State = 1 Then
    End If
    Set objRST2 = Nothing
    'Close connection and deallocate memory space.
    If objCN.State = 1 Then
    End If
    Set objCN = Nothing
    Exit Function

Open in new window

Watch Question


Sorry I neglected to say in my first post that I have ran this routine on both a Dell 2.8ghz w/1.5gb RAM and an Intel Celeron 800 w/512 mb RAM.  Processing times are indentical on both machines.  The Dell is running Vista the Celeron is running XP Pro SP2.

Thank you for any advice or suggestions anybody can kcik my way.
MIS Liason
Most Valuable Expert 2012
This one is on us!
(Get your first solution completely free - no credit card required)


All some very good suggestions.  I will try using some different constructs and see where I get.  You are right in that the number of records are large.  Two of the databases this routine pounds are 20mb+.

Thank you for recognizing this may be as good as it gets and I may need to migrate to SQL.

Thank you for your time and I will let you know the results.

Jeffrey CoachmanMIS Liason
Most Valuable Expert 2012


"Thank you for recognizing this may be as good as it gets and I may need to migrate to SQL."
I never said that you may need to migrate to SQL.

All of the code runs on the front end (Access), not the backend.
Migrating to SQL is not a cure-all.

My point was to try a few tweaks an see if it runs any faster.



I'm sorry.  I didn't mean to make it sound like you suggested migration to SQL.  That was an option that has been kicked around for this application.  I was trying to avoid migrating if possible.  I haven't had a chance to code your suggestions yet, but will do so this afternoon.



I rewrote the procedure in question using your suggestions.  I was able to increase processing times on average 29.75%.  On process that some were taking 10 to 16 minutes to complete that translates into a generous increase.  Even the shorter processes (less than a minute) I saw 20 to 35 second improvements.

I inherited this application through a support contract and this is my first real look at it.  It is UGLY.  May be in for a complete rewrite in VB using SQL as a backend.  We'll see.

Thank you for the advice and making me to review the basics.

Jeffrey CoachmanMIS Liason
Most Valuable Expert 2012

Unlock the solution to this question.
Join our community and discover your potential

Experts Exchange is the only place where you can interact directly with leading experts in the technology field. Become a member today and access the collective knowledge of thousands of technology experts.

*This site is protected by reCAPTCHA and the Google Privacy Policy and Terms of Service apply.


Please enter a first name

Please enter a last name

8+ characters (letters, numbers, and a symbol)

By clicking, you agree to the Terms of Use and Privacy Policy.