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

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

shelbyinfotechAsked:
Who is Participating?
 
ChloesDadConnect With a Mentor Commented:
Yes Martin, it should be after line 43
0
 
Martin LissOlder than dirtCommented:
Between lines 40 and 41 add
.MoveNext
0
 
Martin LissConnect With a Mentor Older than dirtCommented:
Or perhaps between 43 and 44
0
Get expert help—faster!

Need expert help—fast? Use the Help Bell for personalized assistance getting answers to your important questions.

 
Rey Obrero (Capricorn1)Commented:
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
 
shelbyinfotechAuthor Commented:
Thanks !
0
 
GrahamSkanRetiredCommented:
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
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.