snowmantle
Programmer
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.
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.
Code:
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