Copy Function Very Slow

[SGElizabeth]

I had the (mis)fortune to inherit a coworker's VBA application for a client, and I'm having a huge problem with the copy function. The function is supposed to copy the records from one database into another. With small amounts of records, the function works fine, but the DB the client wants to copy has 10K records, and it isn't working. The client says that it used to take only a little over an hour to copy these records and it now will take several hours--we don't know for sure because we've terminated the copy after several hours have passed.

I've been looking over the code, and I think that the function is inefficient and performance-draining. It takes each record from the main table and checks to see if there are any duplicates in the table its being copied to. If not, it copies that record and then copies the records from each related table. While the main table has 10K records, some of the related tables have over 40K each. But, I'm also new to VBA and this type of programming, so maybe I'm off base.

I have no exlanation for why the copy function is suddenly taking so long, but I've tried it with older versions of the database, and I encounter the same problems. I am trying to break up the copying of the main table and the copying of the related tables to see if that will speed up the process.

I'm going to post the code for the current copy process, and I would really, really appreciate it if someone could offer any suggestions for why performance has decreased so dramatically. I'm at my wits' end with this problem!

Public Sub MergeQuoteTables()
On Error GoTo Err_MergeQuoteTables

Dim strPath As String
Dim rc As Integer
Dim filename As String 'Database that will be merged.
Dim DBDir As String 'Directory of current database.
Dim rstto As Recordset 'Records where data will be merged.
Dim rstfrom As Recordset 'Records that will be merged into rstto.
Dim rel As Relation 'Relationships to retrieve linked table names
Dim strFind As String 'Search criteria to find duplicate value in destination table.

'Get file name of quote table to merge.
filename = getfilename("Select Quote File to Merge with Master Quote File", "C:\", "Access Files (*.mdb) | All Files (*.*)")

'Check for a file not being selected. If not select print message.
If filename = "" Or IsNull(filename) Then
MsgBox "You need to select a Quote File to merge."


'If a file is selected, imports that file into a temporary table. Then appends the unique
'records to the existing estimates table. Finally, deletes the temporary table.
Else
Form_Switchboard.lblMsg.Visible = True
'Form_Switchboard.lblMsg = "Your files are being migrated...."
DoCmd.RepaintObject acForm, "switchboard"

DoCmd.Hourglass True

'File has been selected. Get it's information.
DBDir = GetDBDir
Set dbfrom = OpenDatabase(filename)
Set dbto = OpenDatabase(DBDir & EstimateDB)



Set rstfrom = dbfrom.OpenRecordset("SELECT * from " & EstimateTable)
Set rstto = dbtpenRecordset("SELECT * from " & EstimateTable)
Set tdf = dbfrom.TableDefs(EstimateTable)

'Check if any values exist to copy
If rstfrom.RecordCount > 0 Then
'Value is in table.

'Move to first record
rstfrom.MoveFirst

While Not rstfrom.EOF
'Try to find duplicate record in destination table.
strFind = "[Qnum] = '" & rstfrom!QNum & "' AND [Qitem] = '" & rstfrom!QItem & _
"' AND [Qrev] = '" & rstfrom!QRev & "' AND [QINIT] = '" & rstfrom!QInit & "'"

rstto.FindFirst strFind

If rstto.NoMatch Then

'Duplicate value not found. Add value to destination table.
rstto.AddNew

'Copy all the values to new table.
For Each fld In tdf.Fields

If fld.Name <> "ID" Then

rstto(fld.Name) = rstfrom(fld.Name)


End If

Next fld

'Get the old and the new id values
newid = rstto!ID
oldid = rstfrom!ID

rstto.Update


'Update all the adjoining tables. Find tables linked to this table move information to archive table.
For Each rel In dbfrom.Relations
If rel.Table = EstimateTable Then

'Merge associated tables

CopyTableData rel.ForeignTable, rel.ForeignTable, filename, DBDir & EstimateDB, "EstimateID", oldid, newid, "", 0, False

End If
Next rel

'Delete records out of estimate table
'rstfrom.Delete
Else
'Duplicate record was found in destination table. Go to next record in the originating table.
End If

'Go to next record.
rstfrom.MoveNext

Wend

rstfrom.Close
rstto.Close
Set dbfrom = Nothing
Set dbto = Nothing
End If

Form_Switchboard.lblMsg.Visible = False
'Form_Switchboard.lblMsg.Caption = " "
DoCmd.RepaintObject acForm, "Switchboard"
DoCmd.Hourglass False

MsgBox "The quotes have been merged."

End If


Exit_MergeQuoteTables:
Exit Sub

Err_MergeQuoteTables:
MsgBox Err.Description
Resume Exit_MergeQuoteTables
End Sub

Public Sub CopyTableData(tablefrom, tableto, strdbfrom, strdbto, keyfield, oldid, newid, toprefix, tochardelete, DoDelete As Boolean)
Dim strSQL As String
Dim rsfrom As Recordset
Dim rsto As Recordset
Dim tdf As TableDef
Dim databfrom As Database
Dim databto As Database
Dim newfolder As Object
Dim fld As Field
Dim rel As Relation

'Get database names
DBDir = GetDBDir
Set databfrom = OpenDatabase(strdbfrom)
Set databto = OpenDatabase(strdbto)

'Initialize values
strSQL = "SELECT * from " & tablefrom & " WHERE [" & keyfield & "] = " & oldid & ";"
Set rsfrom = databfrom.OpenRecordset(strSQL)
Set rsto = databtpenRecordset(tableto, dbOpenDynaset)
Set tdf = databfrom.TableDefs(tablefrom)

'Check if any values exist to copy
If rsfrom.RecordCount > 0 Then
'Value is in table.
'Move to first record
rsfrom.MoveFirst

While Not rsfrom.EOF
'Record exists. Copy to archive table.
rsto.AddNew

'Copy all the values to new table.
For Each fld In tdf.Fields
If (fld.Name <> keyfield) And ((fld.Attributes And dbAutoIncrField) = 0) Then
'not the keyfield, and not an autonumber field
rsto(fld.Name) = rsfrom(fld.Name)
'MsgBox "Subfield = " & fld.Name & " value = " & rsfrom(fld.Name)
End If
Next fld

rsto(keyfield) = newid
rsto.Update
rsto.MoveLast

For Each rel In databfrom.Relations
If rel.Table = tablefrom Then
Dim newtotable As String

If tochardelete = 0 Then
newtotable = toprefix & rel.ForeignTable
Else
newtotable = Right(rel.ForeignTable, Len(rel.ForeignTable) - tochardelete)
End If

CopyTableData rel.ForeignTable, newtotable, strdbfrom, strdbto, rel.Fields(0).ForeignName, rsfrom(rel.Fields(0).Name), rsto(rel.Fields(0).Name), toprefix, tochardelete, DoDelete
End If
Next

If DoDelete Then
'Delete the current record
rsfrom.Delete
End If

'Move to the next record
rsfrom.MoveNext
Wend

End If

rsto.Close
rsfrom.Close
Set databfrom = Nothing
Set databto = Nothing
End Sub

 

[nabiS2K]

When using DAO to cycle through recordsets in this manner, the process will be much slower than necessary, as you notice.

The most efficient way to perform this kind of update is with an append query which joins the two tables together and only copies the unique records. This will run much, much faster...

Does this help or do you need more specifics?

 

[SGElizabeth]

I'm so glad someone else thinks it is inefficient too! I think I understand what you are saying about the append query. How will using an append query affect the copies I need to make to the related tables? The main table is related to about 10 other tables and 2 of those 10 tables have 3 other tables related to them.

 

[nabiS2K]

You will need an append query for each of the different relational tables. You will also have to run them in order where you populate foreign key tables prior to detail tables.