I'm trying to figure out how to speed up this operation. Before I import a record from the text file I first need to see if one exists in the database. If it does exist I'm going to perform an update operation on it. If it does not exist I'm going to create a new record.
Running the code you see below this operation takes somewhere in the neighborhood of 3 hours.
I've tried using ADO's find method and it actually appears to be slower than the filter method.
The database is a Visual Foxpro 6 database. The table does have an index on the item_cd field but the table does not have any primary key established. This is out of my control since I didn't write the software and I'm trying to stay away from making any structural changes to the database.
There are 46652 rows in the text file and about 650,000 records/rows in the ADO recordset. I think slimming down the recordset would be the biggest step in fixing this but I haven't come up with any way of doing that. I'm trying to prevent creating duplicate records since there is no primary key and so I really need to have the entire table in my recordset.
Because I'm running this on my local machine it appears that the operation is limited by the power of the CPU. In actuality this might be used across the network, especially if I can get it to go faster.
Dim sFileToImport As String
sFileToImport = Me.lstFiles.Text
If sFileToImport = "" Then
MsgBox "You must select a file from the listbox to import."
Exit Sub
End If
If fConnectToDatabase = False Then Exit Sub
With gXRst
.CursorLocation = adUseClient
.CursorType = adOpenKeyset
.LockType = adLockReadOnly
.Open "SELECT item_cd FROM xmsalinv ORDER BY item_cd ASC", gXCon
End With
Call fStartProgress("Running speed test.")
Dim rstTxtFile As ADODB.Recordset
Set rstTxtFile = New ADODB.Recordset
Dim con As ADODB.Connection
Set con = New ADODB.Connection
Dim sConString As String, sSQL As String
Dim lRecCount As Long, l As Long
Dim s As String
sConString = "DRIVER={Microsoft Text Driver (*.txt; *.csv)};Dbq=" & gsImportFolderPath & ";Extensions=asc,csv,tab,txt;Persist Security Info=False;"
con.Open sConString
sSQL = "SELECT * FROM [" & sFileToImport & "]"
rstTxtFile.Open sSQL, con, adOpenKeyset, adLockPessimistic
If Not (rstTxtFile.EOF And rstTxtFile.BOF) = True Then
rstTxtFile.MoveFirst
lRecCount = rstTxtFile.RecordCount
Do Until rstTxtFile.EOF = True
'This code appears to actually be slower than the filter method I'm now using
'gXRst.MoveFirst
'gXRst.Find "item_cd = '" & fPQ(Trim(rstTxtFile(0))) & "'"
gXRst.Filter = "item_cd = '" & fPQ(Trim(rstTxtFile(0))) & "'"
If Not (gXRst.EOF And gXRst.BOF) = True Then
s = "Item Found - " & Trim(rstTxtFile(0)) 'item found
Else
s = "Item Not Found - " & Trim(rstTxtFile(0)) 'Item not found found
End If
l = l + 1
Call subProgress(l, lRecCount, s)
rstTxtFile.MoveNext
Loop
End If
Call fEndProgress("Finished running speed test.")
Cleanup:
rstTxtFile.Close
Set rstTxtFile = Nothing
gXRst.Close
In response to Bob Riemersma's post, the text file is not causing the speed issues. I've changed my code to open a recordset with a query looking for a single item. This code now runs in 1 minute and 2 seconds as opposed to the three to four hours I was looking at the other way.
Dim sFileToImport As String
sFileToImport = Me.lstFiles.Text
If sFileToImport = "" Then
MsgBox "You must select a file from the listbox to import."
Exit Sub
End If
If fConnectToDatabase = False Then Exit Sub
Call fStartProgress("Running speed test.")
Dim rstTxtFile As ADODB.Recordset
Set rstTxtFile = New ADODB.Recordset
Dim con As ADODB.Connection
Set con = New ADODB.Connection
Dim sConString As String, sSQL As String
Dim lRecCount As Long, l As Long
Dim sngQty As Single, sItemCat As String
sConString = "DRIVER={Microsoft Text Driver (*.txt; *.csv)};Dbq=" & gsImportFolderPath & ";Extensions=asc,csv,tab,txt;Persist Security Info=False;"
con.Open sConString
sSQL = "SELECT * FROM [" & sFileToImport & "]"
rstTxtFile.Open sSQL, con, adOpenKeyset, adLockPessimistic
If Not (rstTxtFile.EOF And rstTxtFile.BOF) = True Then
rstTxtFile.MoveFirst
lRecCount = rstTxtFile.RecordCount
Do Until rstTxtFile.EOF = True
l = l + 1
sItemCat = fItemCat(Trim(rstTxtFile(0)))
If sItemCat <> "[item not found]" Then
sngQty = fItemQty(Trim(rstTxtFile(0)))
End If
Call subProgress(l, lRecCount, sngQty & " - " & sItemCat & " - " & rstTxtFile(0))
sngQty = 0
rstTxtFile.MoveNext
Loop
End If
Call fEndProgress("Finished running speed test.")
Cleanup:
rstTxtFile.Close
Set rstTxtFile = Nothing
My Functions:
Private Function fItemCat(sItem_cd As String) As String
'Returns blank if nothing found
If sItem_cd <> "" Then
With gXRstFind
.CursorLocation = adUseClient
.CursorType = adOpenKeyset
.LockType = adLockReadOnly
.Open "SELECT item_cd, ccategory FROM xmsalinv WHERE item_cd = '" & fPQ(sItem_cd) & "'", gXCon
End With
If Not (gXRstFind.EOF And gXRstFind.BOF) = True Then
'An item can technically have a blank category although it never should have
If gXRstFind!ccategory = "" Then
fItemCat = "[blank]"
Else
fItemCat = gXRstFind!ccategory
End If
Else
fItemCat = "[item not found]"
End If
gXRstFind.Close
End If
End Function
Private Function fIsStockItem(sItem_cd As String, Optional bConsiderItemsInStockAsStockItems As Boolean = False) As Boolean
If sItem_cd <> "" Then
With gXRstFind
.CursorLocation = adUseClient
.CursorType = adOpenKeyset
.LockType = adLockReadOnly
.Open "SELECT item_cd, bal_qty, sug_qty FROM xmsalinv WHERE item_cd = '" & fPQ(sItem_cd) & "'", gXCon
End With
If Not (gXRstFind.EOF And gXRstFind.BOF) = True Then
If gXRstFind!sug_qty > 0 Then
fIsStockItem = True
Else
If bConsiderItemsInStockAsStockItems = True Then
If gXRstFind!bal_qty > 0 Then
fIsStockItem = True
End If
End If
End If
End If
gXRstFind.Close
End If
End Function
Private Function fItemQty(sItem_cd As String) As Single
'Returns 0 if nothing found
If sItem_cd <> "" Then
With gXRstFind
.CursorLocation = adUseClient
.CursorType = adOpenKeyset
.LockType = adLockReadOnly
.Open "SELECT item_cd, bal_qty FROM xmsalinv WHERE item_cd = '" & fPQ(sItem_cd) & "'", gXCon
End With
If Not (gXRstFind.EOF And gXRstFind.BOF) = True Then
fItemQty = CSng(gXRstFind!bal_qty)
End If
gXRstFind.Close
End If
End Function