We help IT Professionals succeed at work.

VBA Bombs Error 3052 Updating Record Set

UWW_Jax
UWW_Jax asked
on
How can I get the code to run faster and run with out bombing.  I have over 1 million records, database is 1.28 gig.


Function UpdateCumuMissing()

'On Error GoTo Error123

Dim db As DAO.Database
Dim rs, Rst As DAO.Recordset
Dim Matchkey As String
Dim i, j, k As Integer
Dim Monthkey As String
Dim txtyyyyMM As String

'i = 0
  Set db = CurrentDb
  Set rs = db.OpenRecordset("Qry_UP_MissingIxosCertReview", dbOpenDynaset)
  

    rs.MoveFirst
    Matchkey = rs!sys_cust_St
    txtyyyyMM = Format(rs!yyyymm, "@@@@_@@")
    'Monthkey = ReviewCertKey(txtyyyyMM, Matchkey)
    
While Not rs.EOF
  'i = i + 1
  
  'Select Case i
  'Case Is = 10000, 50000, 100000, 200000, 300000, 500000
  'MsgBox i / rs.RecordCount & "    " & i
  'End Select
  
  
    Set Rst = db.OpenRecordset("SELECT [" & txtyyyyMM & "] As Expr1 FROM tbl_Customer_Certs WHERE (Sys_cust_st ='" & Matchkey & "')")
    
    Monthkey = Rst!Expr1
    'SELECT [" & Txtyyymm & "]* FROM tbl_Customer_Certs WHERE (Sys_cust_st ='" & matchkey & "')")
  
  
  'rs.Update
  rs.Edit
  rs!IxosCertDateMatch = Monthkey
  'rs!AnotherField = SomeOtherValue
  rs.Update
  rs.MoveNext
  Set Rst = Nothing
Wend
  Set rs = Nothing
  Set db = Nothing
MsgBox "Complete"



MsgBox "Complete"

ErrorExit:
    Exit Function
Error123:
    Set Rst = Nothing
    Set rs = Nothing
    Set db = Nothing
    MsgBox Err.Description & vbNewLine & Err.Number & vbNewLine & Err.Source
Resume ErrorExit


End Function

Open in new window

Comment
Watch Question

CERTIFIED EXPERT

Commented:
I think this is two distinct questions.
What error is being produced and on what line does it occur?
Dale FyeOwner, Dev-Soln LLC
CERTIFIED EXPERT
Most Valuable Expert 2014
Top Expert 2010

Commented:

The first step would be to write an update query, instead of opening a recordset and looping through it record by record.

The other thing I'm concerned with is that you are setting MatchKey and txtYYYYMM based on rs, but do this outside the loop for that recordset.  Does this mean that every record in "Qry_UP_MissingIxosCertReview" contains the same values for MatchKey and txtYYYYMM?  If not, then you need to move those lines inside of the While Not rs.EOF/Wend loop.

Does your rst recordset only return a single value?  If so, why are you using that instead of a DLOOKUP()?  If not, why aren't you looping through that recordset as well?
UWW_JaxSr Tax Accountant

Author

Commented:
OKay, I'd tryied difference approaches.   Here's how the data works.

I have two main tables.

Tbl_Customer_Certs.  This has a listing of sys_cust_st (refering to matchkey) with all of the YYYY_MM' s listed as a column from 2006 through 2021.  These fields are true/False check boxes.

Tbl_CumulativeMissing This contains sales details with tons of columns that I have narrowed down to three columns need for this exercise I have put into Qry_UP_MissingIxosCertReview which are Sys_cust_st, YYYYMM, and IxosCertDateMatch.

This Idea is to loop through the million records of Qry_UP_MissingIxosCertReview and for each line look for the YYYYMM reference in the Tbl_customer_Certs column setup as YYYY_MM.

If there is no match between the tables I need to put NoDoc into IxosCertDateMatch field

If there is a match between the tables and the YYYY_M is blank/no checked, I need to put Unmatched into IxosCertDateMatch field

If there is a match between the tables and the YYYY_M is -1/checked, I need to put matched into IxosCertDateMatch field

I had a Function that did a dlookup for and then updated based upon the finding, but I could not get it to perform quick.

I just ran the code again to tell you the error, and it completed after 5/10 minutes.

I was thought that code runs faster than update queries because of the lookup format issues with mass data.






Function ReviewCertKey(xmonth, xmatchkey As String) As String
Dim txtReview, txtFound As String
txtReview = "NoDoc"

xmonth = "[" & Format(xmonth, "@@@@_@@") & "]"

Select Case Nz(DLookup(xmonth, "Tbl_Customer_Certs", "[sys_cust_st]='" & xmatchkey & "'"), txtReview)

Case Is = -1
txtFound = "Match"
Case Is = 0
txtFound = "UnMatched"
Case Is = txtReview
txtFound = txtReview
End Select

'ReviewCertKey = Nz(DLookup("[" & Format(xmonth, "@@@@_@@") & "]", "Tbl_Customer_Certs", "[sys_cust_st]='" & xmatchkey & "'"), txtReview)
ReviewCertKey = txtFound


End Function

Open in new window

UWW_JaxSr Tax Accountant

Author

Commented:
I was also using a qry to sort and pick a selection of data to test rather than running on the population.
Dale FyeOwner, Dev-Soln LLC
CERTIFIED EXPERT
Most Valuable Expert 2014
Top Expert 2010

Commented:
Can you provide a sample database with a subset of each of these tables, the query you are using, and a sample of what the result this process would generate?

You could do this with a couple of make-table queries to select a small subset (5-10 records) from each table, then copy these tables into a new mdb, along with the query you were using above.  Then make a copy of tbl_CumulativeMissing and fill in the [rs!IxosCertDateMatch] column for each of those records
Sr Tax Accountant
Commented:
I updated some of code.  What I'm thinking is that if I can have this process run as one large batch instead of looping through each line update. that it will run faster.  The Code currently takes about 15-20 minutes.  which is better than I could get it on my original posting.



Function UpdateCumuMissing()

'On Error GoTo Error123

Dim db As DAO.Database
Dim rs, Rst As DAO.Recordset
Dim Matchkey As String
Dim i, j, k As Integer
Dim Monthkey As String
Dim txtyyyyMM As String
Dim TxtUpdate As String
Dim txtEdit As String

i = 0
  Set db = CurrentDb
  Set rs = db.OpenRecordset("Select * From Qry_UP_MissingIxosCertReview")
  
  If rs.RecordCount = 0 Then

  Set rs = Nothing
  Set db = Nothing

MsgBox "No Records to Change"
  Else
  
  
  rs.MoveFirst

 'i = i + 1
 ' Select Case True
 'Case Is = 10000, 50000, 100000, 200000, 500000
 'MsgBox (i / rs.RecordCount)
 'End Select
 
 Do Until rs.EOF
    Matchkey = rs!sys_cust_St
    txtyyyyMM = Format(rs!yyyymm, "@@@@_@@")
    
 
 
 
  'MsgBox i
    Monthkey = ""
    Set Rst = db.OpenRecordset("Select [" & txtyyyyMM & "] As Expr1 From Tbl_Customer_Certs Where(sys_cust_St='" & Matchkey & "')")
    
    If Rst.RecordCount = 0 Then
    txtEdit = "NoDoc"
    Else
    txtEdit = Nz(Rst!Expr1, "NoDoc")
    End If
    Set Rst = Nothing
    
   Select Case txtEdit
   Case Is = "NoDoc"
   Monthkey = "NoDoc"
   Case Is = True
   Monthkey = "Match"
   Case Is = False
   Monthkey = "unmatch"
   End Select
  
  
    'rs.Update
  rs.Edit
  rs!IxosCertDateMatch = Monthkey
  rs!IxosCertDateMatchDate = Date
  'rs!AnotherField = SomeOtherValue
  rs.Update
  rs.MoveNext
  
  
 Loop



  Set rs = Nothing
  Set db = Nothing

MsgBox "Complete"

End If


ErrorExit:
    Exit Function
Error123:
    Set Rst = Nothing
    Set rs = Nothing
    Set db = Nothing
    MsgBox Err.Description & vbNewLine & Err.Number & vbNewLine & Err.Source
Resume ErrorExit


End Function

Open in new window

Dale FyeOwner, Dev-Soln LLC
CERTIFIED EXPERT
Most Valuable Expert 2014
Top Expert 2010

Commented:
Please provide a sample database as indicated above.  Without it, I'm just spinning my wheels.
UWW_JaxSr Tax Accountant

Author

Commented:
I have attached a database where as 75% of the items in the CumulativeMissing table has been deleted due to sight size limitations.
Copy-of-STAR-3.0.accdb
UWW_JaxSr Tax Accountant

Author

Commented:
Never Received a followup response.  Closing issue

Explore More ContentExplore courses, solutions, and other research materials related to this topic.