Speeding up a couple of Excel subroutines

[snowmantle]

Hi, I am asking for some help to improve the speed of the below subs. Specifically taking ~5mins in Excel when I run through a list of 5500 unique 18 digit text codes.

I am using a query in an access dbase so that I can use these subs on different joined tables trying to keep things simple but I realise its not being very efficient.

I am guessing in saying that Application.StatusBar inside the loop will be creating a lot of strings which will slow things down and use up a lot more memory.. but its the only good feedback method I have come up with so far.

I am also doing a recordset filter to check for the relevant records.

The point of these subs is that I have a range that has been filtered to find all the unique values. These cells all then get checked with the database to see if they already exist and if they DO then they are deleted.

For all that do exist already the primary key is put into the cell in place of its value.. this is done for about 6 columns that are not always in the same order.. once I have all the keys in place I am going to import this combined information into another table in the database.

Sub RemoveExisting(removeRange As Range, qryTableName As String)
'using this to remove any existing descriptions from a filtered worksheet by checking
'a query in the database and then deleting the relevant rows
    Dim conn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim myDB As String
    Dim sqlStr As String
    Dim r As Long
    Dim lastRow As Long
    
    myDB = ThisWorkbook.path & "\" & "master.mdb"
    Set conn = New ADODB.Connection
    conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & myDB & ";"
    
    sqlStr = "SELECT [description],[replacekey] FROM [" & qryTableName & "] ORDER BY [description]"
    
    Set rs = New ADODB.Recordset
    rs.Open sqlStr, conn, adOpenStatic, adLockReadOnly

    Application.StatusBar = "Checking " & qryTableName & " to remove existing records"
    
    lastRow = removeRange.Rows.Count
    Application.ScreenUpdating = False
    For r = lastRow To 1 Step -1
        'filter the recordset description to find what we want
        rs.filter = " description = '" & Trim(CStr(removeRange.Cells(r, 1).Value)) & "'"
        If rs.RecordCount > 0 Then
            'Delete row
            'Application.StatusBar = "deleting row " & r
            removeRange.Rows(r).Delete
        End If
        rs.filter = adFilterNone
        
        Application.StatusBar = "checking for existing: " & r & " record(s) to go"
    Next r
    Application.ScreenUpdating = True
    
    ' Close the connections and clean up.
    rs.Close
    conn.Close
    Set rs = Nothing
    Set conn = Nothing
End Sub

Sub InsertCorrectKeys(titleColumn As Range, qryTableName As String)
'checks a query table and gets all the relevant keys and changes the values in the worksheet
'with the correct ACCESS primary keys for use with importing later
    Dim conn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim myDB As String
    Dim lastRow As Long
    Dim r As Long
    
    Application.ScreenUpdating = False
    lastRow = titleColumn.Rows.Count
    
    myDB = ThisWorkbook.path & "\" & "master.mdb"
    Set conn = New ADODB.Connection
    conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & myDB & ";"
    Set rs = New ADODB.Recordset
    
    sql = "SELECT [description],[replacekey] FROM [" & qryTableName & "] ORDER BY description"
    rs.Open sql, conn, adOpenStatic, adLockReadOnly
    
    'Application.StatusBar = "inserting the correct keys for " & titleColumn.Cells(1, 1).Value
    
    progressCount = 0
    'starting from 2 because we dont want the title to be included
    For r = 2 To lastRow
        rs.filter = rs.Fields(0).Name & " = '" & Trim(CStr(titleColumn.Cells(r, 1).Value)) & "'"
        If rs.RecordCount > 0 Then
            titleColumn.Cells(r, 1).Value = rs.Fields(1).Value
        Else
            bNotAllKeysFound = True
        End If
        rs.filter = adFilterNone
        'display the % of rows complete over total rows in range
        'r starts at 2 but that will just add to the progress
        Application.StatusBar = "inserting keys for " & titleColumn.Cells(1, 1).Value & " : " & CInt((r / lastRow) * 100) & "%"
    Next
    Application.ScreenUpdating = True
    rs.Close
    conn.Close
    Set conn = Nothing
    Set rs = Nothing
End Sub

 

[snowmantle]

Sorry just to add to this further.. when insertcorrectkeys is run that is being done on 16600 rows because the raw data has duplicates that need to be replaced too.

Thanks

 

[snowmantle]

anyone got any suggestions on the above?

I was thinking about doing multiple queries that only get 1000 rows a time from the database to try and cut down how much work needs to be done depending on the sort of the id's.

 

[xlbo]

Would be tempted to append ALL the data from excel to access into a temp table then do a non matching query there and return records to excel afterwards...

Rgds, Geoff

We could learn a lot from crayons. Some are sharp, some are pretty and some are dull. Some have weird names and all are different colours but they all live in the same box.

Please read FAQ222-2244 before you ask a question

 

[snowmantle]

Thanks Geoff, decided to change my work and do it the way you suggest. Here is some of my update code so far

I am having a problem with the bit of code that is meant to delete the records from the temp table via the tempRs recordset.

I get a runtime error 3219: operation is not allowed in this context.

I dont understand why when .Delete adAffectAll tooltip says that it deletes all records? I tried looping through a deleting one at a time too but I got some other runtime error too that I cant remember.

Thanks for any help.

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
    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) = FormatCode(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 And qryRs.RecordCount > 0
        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
    
    'once we are finished going to delete everything in the temporary table
    tempRs.MoveFirst
    tempRs.Delete adAffectAll
    tempRs.UpdateBatch


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