Copy Headers (1 Viewer)

[Lgvalencia]

I inherited this DB and it has a function to copy all the Headers from one program to a new program and it stopped working. I am not sure if a software update has changed the way it performs or what. If anyone can help figure out what is wrong, that would be helpful.

Private Sub BSTART_Click()
On Error GoTo Err_BSTART_Click

    Dim MyDB As Database
    Dim MySet1 As Recordset
    Dim MySet2 As Recordset
    Dim Criteria As String

    Set MyDB = DBEngine.Workspaces(0).Databases(0)
    Set MySet1 = MyDB.OpenRecordset("CDRL Header", DB_OPEN_DYNASET)
    Set MySet2 = MyDB.OpenRecordset("CDRL Header", DB_OPEN_DYNASET)

    If IsNull(Me![Program1]) Then GoTo Exit_BSTART_Click
    If IsNull(Me![Program2]) Then GoTo Exit_BSTART_Click

    Criteria = "[Program] = '" & Me![Program1] & "'"
    If IsNull(DLookup("[Program]", "Program", Criteria)) Then
        MsgBox ("Program 1 does not exist")
        GoTo Exit_BSTART_Click
    End If
    
    Criteria = "[Program] = '" & Me![Program2] & "'"
    If IsNull(DLookup("[Program]", "Program", Criteria)) Then
        MsgBox ("Program 2 does not exist")
        GoTo Exit_BSTART_Click
    End If

    DoCmd.Hourglass True
    
    Criteria = "[Program] = '" & Me![Program1] & "'"
    MySet1.FindFirst Criteria
    On Error GoTo Err_BSTART_Click

    While Not MySet1.NoMatch
        MySet2.AddNew
        MySet2![Program] = Me![Program2]
        MySet2![CDRL Number] = MySet1![CDRL Number]
        MySet2![CDRL Type] = MySet1![CDRL Type]
        MySet2![CDRL Usage] = MySet1![CDRL Usage]
        MySet2![Description] = MySet1![Description]
        MySet2![Responsibility] = MySet1![Responsibility]
        MySet2![DID Number] = MySet1![DID Number]
        MySet2![DID Requirement] = MySet1![DID Requirement]
        MySet2![Notes] = MySet1![Notes]
        MySet2![Days To Approve] = MySet1![Days To Approve]
        MySet2.Update
        MySet1.FindNext Criteria
    Wend

    MySet1.Close
    MySet2.Close
    DoCmd.Hourglass False
    MsgBox ("Finished copying CDRL Headers")
    DoCmd.Close

Exit_BSTART_Click:
    Exit Sub

Err_BSTART_Click:
    DoCmd.Hourglass False
    MsgBox Err.Description
    Resume Exit_BSTART_Click
    
End Sub

 

[Gasman]

Have you tried walking the code with F8 and some breakpoints?
Perhaps qualify the recordset/database objects with DAO ?

 

[June7]

"Stopped working" means what - error message, wrong result, nothing happens?

Disable OnError GoTo line then run code so debugger will break on line causing error.

Learn debugging techniques https://www.techonthenet.com/access/tutorials/vbadebug2010/debug01.php

 

[Gasman]

You would probably be better off just getting the records that match in the first recordset, and walking that until EOF.
I know you inherited it, but that doesn't mean you cannot make it better.