Max locks to Access database

[snowmantle]

Hi, the below code seems to work ok.. It adds records to a temp table, compares them with the existing table using a query and then imports the ones that dont match as new records.. then deletes the records in the temp table.

The only issue I seem to have at the moment is when deleting around about 15000 records I get an error saying I have reached the maximum number of locks.

I checked this out and Access is set to 9500, I cant have other users changing their registry.. and the other approach seems to be to reset the Access database when it is opened by setting the max locks number, as I dont want the Access dbase opening all the time that isnt an option either.

Does anyone have any suggestions on how to improve the below code? I am thinking I may need to break up the delete so that it only does 9000 records at a time or something??

unless there is a better way, I dont know I barely knew how to do the below.

Sub UpdatePallets(srcRng As Range)
    Dim conn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim tempRs As ADODB.Recordset
    Dim qryRs As ADODB.Recordset
    Dim myDB As String
    Dim sqlStr As String
    Dim r As Long
    
    Application.ScreenUpdating = False
    
    myDB = ThisWorkbook.path & "\" & DBNAME
    Set conn = New ADODB.Connection
    conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & myDB & ";"
    
    Set tempRs = New ADODB.Recordset
    Set qryRs = New ADODB.Recordset
    Set rs = New ADODB.Recordset

    lastRow = srcRng.Rows.Count
    
    Application.StatusBar = "Updating pallet information"
    sqlStr = "SELECT [pallet_sscc],[buscat_fkey],[supplier_fkey],[product_code],[supplier_sscc] FROM [TempPallets]"
    tempRs.Open sqlStr, conn, adOpenDynamic, adLockOptimistic 'using dynamic and optimistic because we are updating and deleting
    
    'importing records from excel into a temporary pallet table because this is pretty quick
    'and can then be cross referenced with the existing table quickly
    'these codes have already been formatted to be of the correct length
    For r = 1 To lastRow
        With tempRs
            .AddNew
            'pallet_sscc
            .Fields(0) = Trim(CStr(srcRng.Cells(r, 1).Value))
            'buscat_fkey
            .Fields(1) = CInt(srcRng.Cells(r, 3).Value)
            'supplier_fkey
            .Fields(2) = CInt(srcRng.Cells(r, 5).Value)
            'product_code
            .Fields(3) = Trim(CStr(srcRng.Cells(r, 2).Value))
            'supplier_sscc
            .Fields(4) = Trim(CStr(srcRng.Cells(r, 4).Value))
            .Update
        End With
        Application.StatusBar = "Entering temp pallet info: " & CInt((r / lastRow) * 100) & "%"
    Next r
    
    'open a connection to the query table
    sqlStr = "SELECT [pallet_sscc],[buscat_fkey],[supplier_fkey],[product_code],[supplier_sscc] FROM [PalletsWithoutMatch]"
    qryRs.Open sqlStr, conn, adOpenForwardOnly, adLockReadOnly ' forward and read only because we are not changing the query this will save time
    
    'open a connection to the pallet table
    sqlStr = "SELECT [pallet_sscc],[buscat_fkey],[supplier_fkey],[product_code],[supplier_sscc] FROM [Pallets] ORDER BY [pallet_sscc]"
    rs.Open sqlStr, conn, adOpenForwardOnly, adLockOptimistic 'optimistic for updating records

    'loop through adding any non matched records in as new pallets
    Do While Not qryRs.EOF
        With rs
            .AddNew
            'pallet_sscc
            .Fields(0) = qryRs.Fields(0)
            'buscat_fkey
            .Fields(1) = qryRs.Fields(1)
            'supplier_fkey
            .Fields(2) = qryRs.Fields(2)
            'product_code
            .Fields(3) = qryRs.Fields(3)
            'supplier_sscc
            .Fields(4) = qryRs.Fields(4)
            .Update
        End With
        Application.StatusBar = "updating pallet info: " & CInt((r / lastRow) * 100) & "%"
    Loop
    
    'closing these now to reduce the amount of locks to the ACCESS file
    rs.Close
    qryRs.Close
    Set rs = Nothing
    Set qryRs = Nothing
    
    'once we are finished going to delete everything in the temporary table
    tempRs.MoveFirst
     If Not tempRs.EOF Then
        Do While Not tempRs.EOF
            tempRs.Delete
            tempRs.MoveNext
        Loop
    End If


    Application.ScreenUpdating = True
    ' Close the connections and clean up.
    
    tempRs.Close
    conn.Close
    Set tempRs = Nothing
    Set conn = Nothing
End Sub

 

[PHV]

Why not simply use a Command like this ?
DELETE FROM [TempPallets]

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886