?
Solved

Bug in VBA Code to loop and repeat records in another table

Posted on 2013-12-10
6
Medium Priority
?
275 Views
Last Modified: 2013-12-10
The below function should take records from the query ppPidList2 and append them one at a time as many times as the field REPEAT says in the table tblPrint.

Instead it locks the PC as it continues to add the first record to infinity.

Function MakeData()
Dim StrSQL As String
Dim db As Database                  'Current database.
Dim lng As Long                     'Loop controller.
Dim rs As DAO.Recordset             'Table to append to.
Dim lng1 As Long                     'Loop controller.
Dim rs1 As DAO.Recordset             'Table to append from.
Dim ACCOUNT As String
Dim YEAR As String
Dim USER As String
Dim REPEAT As Integer
Dim TYPEREC As String

    
'StrSQL = "Delete * from tblPrint where user =" & fOSUserName() & ";"
'DoCmd.SetWarnings False
'DoCmd.RunSQL StrSQL
'DoCmd.SetWarnings True

 
    Set db = DBEngine(0)(0)
    Set rs1 = db.OpenRecordset("select * from ppPidList2 ;")
    Set rs = db.OpenRecordset("tblPrint", dbOpenDynaset, dbAppendOnly)
    
      Do While Not rs1.EOF
           ACCOUNT = rs1!ACCOUNT
           YEAR = rs1!YEAR
           USER = rs1!USER
           REPEAT = rs1!REPEAT
           TYPEREC = rs1!TYPE
           
    Set rs = db.OpenRecordset("tblPrint", dbOpenDynaset, dbAppendOnly)
    With rs
        For lng = 1 To REPEAT
            .AddNew
            !ACCOUNT = ACCOUNT
            !YEAR = YEAR
            !USER = USER
            !TYPE = TYPEREC
            .Update
        Next
    End With
    rs.Close
       Loop
    Set rs = Nothing
    Set db = Nothing
        Set rs1 = Nothing
    Set db = Nothing
    End Function

Open in new window

0
Comment
Question by:shelbyinfotech
6 Comments
 
LVL 50

Expert Comment

by:Martin Liss
ID: 39709845
Between lines 40 and 41 add
.MoveNext
0
 
LVL 50

Assisted Solution

by:Martin Liss
Martin Liss earned 1000 total points
ID: 39709849
Or perhaps between 43 and 44
0
 
LVL 15

Accepted Solution

by:
ChloesDad earned 1000 total points
ID: 39709918
Yes Martin, it should be after line 43
0
NFR key for Veeam Agent for Linux

Veeam is happy to provide a free NFR license for one year.  It allows for the non‑production use and valid for five workstations and two servers. Veeam Agent for Linux is a simple backup tool for your Linux installations, both on‑premises and in the public cloud.

 
LVL 120

Expert Comment

by:Rey Obrero (Capricorn1)
ID: 39709930
try this revision , look for   'add this line
Function MakeData()
Dim StrSQL As String
Dim db As Database                  'Current database.
Dim lng As Long                     'Loop controller.
Dim rs As DAO.Recordset             'Table to append to.
Dim lng1 As Long                     'Loop controller.
Dim rs1 As DAO.Recordset             'Table to append from.
Dim ACCOUNT As String
Dim YEAR As String
Dim USER As String
Dim REPEAT As Integer
Dim TYPEREC As String

    
'StrSQL = "Delete * from tblPrint where user =" & fOSUserName() & ";"
'DoCmd.SetWarnings False
'DoCmd.RunSQL StrSQL
'DoCmd.SetWarnings True

 
    Set db = DBEngine(0)(0)
    Set rs1 = db.OpenRecordset("select * from ppPidList2 ;")
    Set rs = db.OpenRecordset("tblPrint", dbOpenDynaset, dbAppendOnly)
    
      Do While Not rs1.EOF
           ACCOUNT = rs1!ACCOUNT
           YEAR = rs1!YEAR
           USER = rs1!USER
           REPEAT = rs1!REPEAT
           TYPEREC = rs1!TYPE
           
    Set rs = db.OpenRecordset("tblPrint", dbOpenDynaset, dbAppendOnly)
			With rs
				For lng = 1 To REPEAT
					.AddNew
					!ACCOUNT = ACCOUNT
					!YEAR = YEAR
					!USER = USER
					!TYPE = TYPEREC
					.Update
				Next
			End With
			rs.Close
			
			rs1.Movenext   'add this line
			
       Loop
    Set rs = Nothing
    Set db = Nothing
        Set rs1 = Nothing
    Set db = Nothing
    End Function
                                  

Open in new window

0
 

Author Comment

by:shelbyinfotech
ID: 39709937
Thanks !
0
 
LVL 76

Expert Comment

by:GrahamSkan
ID: 39709946
Incidentally, all those line like
Set object = Nothing 

Open in new window

lines are redundant.
They don't do anything that simply doesn't happen when the objects go out of scope - the end of the procedure in this case. VB(A) does that automatically
0

Featured Post

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

With its various features, Office 365 can not only help you with your day-to-day business tasks, it can also do wonders for your marketing campaign.
If you’re using QODBC to update QuickBooks data from Microsoft® Access but Access is not showing the updated data, you could have set up QODBC incorrectly.
Polish reports in Access so they look terrific. Take yourself to another level. Equations, Back Color, Alternate Back Color. Write easy VBA Code. Tighten space to use less pages. Launch report from a menu, considering criteria only when it is filled…
With just a little bit of  SQL and VBA, many doors open to cool things like synchronize a list box to display data relevant to other information on a form.  If you have never written code or looked at an SQL statement before, no problem! ...  give i…

850 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question