access updating recordsets is sooo slow

Sub applydescriptionstoproducts()


Dim cnn As ADODB.Connection
Set cnn = New ADODB.Connection

cnn.ConnectionString = strcnn
cnn.Open CurrentProject.Connection


Dim strprodcode As String
Dim strDescription As String
Dim strSummary As String
Dim strName As String
Dim prodrs As ADODB.Recordset
Dim deeprodrs As ADODB.Recordset
Dim proddesrs As ADODB.Recordset
Dim productid As Integer

Set prodrs = New ADODB.Recordset
prodrs.ActiveConnection = CurrentProject.Connection
prodrs.Source = "vgm_products"
prodrs.CursorType = adOpenDynamic
prodrs.LockType = adLockOptimistic

Set deeprodrs = New ADODB.Recordset
deeprodrs.ActiveConnection = CurrentProject.Connection
deeprodrs.Source = "products"
deeprodrs.CursorType = adOpenDynamic
deeprodrs.LockType = adLockOptimistic

Set proddesrs = New ADODB.Recordset
proddesrs.ActiveConnection = CurrentProject.Connection
proddesrs.Source = "vgm_product_desc"
proddesrs.CursorType = adOpenDynamic
proddesrs.LockType = adLockOptimistic


prodrs.Open "SELECT vgm_products.[code],vgm_products.[product_id] FROM vgm_products "
Do Until prodrs.EOF
    strDescription = " "
    strSummary = " "
    strName = " "
    
    
    strprodcode = prodrs!code
    productid = prodrs!product_id
    Debug.Print productid

    
    deeprodrs.Open "SELECT products.[short_desc],products.[name],products.[description] FROM products WHERE (((products.[ProductStyle])= " & Chr(34) & strprodcode & Chr(34) & "));"
    
    Do Until deeprodrs.EOF
            Rem there are blanks in this column so we need to ignore this error
            Rem that is caused by assigning null to a string
            On Error GoTo emptystringerror:
            strDescription = deeprodrs!Description
            strSummary = deeprodrs![short_desc]
            strName = deeprodrs![Name]
            deeprodrs.MoveNext
    Loop
        
      
    deeprodrs.Close
    
       
       
       
   proddesrs.Open "SELECT * FROM vgm_product_desc WHERE (((vgm_product_desc.[product_id])= " & productid & "));"
   Rem if we found it save the id
   Do Until proddesrs.EOF
       proddesrs![Description] = strDescription
       proddesrs![summary] = strSummary
       proddesrs![Name] = strName
       proddesrs.MoveNext
   Loop

   proddesrs.Close
   

    prodrs.MoveNext
Loop

Rem all done close recordsets
prodrs.Close


Set prodrs = Nothing
Set deeprodrs = Nothing
Set proddesrs = Nothing

Rem close the database connection
cnn.Close
Set cnn = Nothing
Exit Sub


emptystringerror:
    Resume Next
Exit Sub


End Sub

Select all Open in new window