I struggle with below issue i googling for this issue several nights and i found a code but need to help
The issue is i need to duplicate records in main form , sub form and "subsubform" 3 levels deep
I found code in below link
but unfortunately this post since 2008 I think its from archive files
anyway i try this code in my database and its works for duplicate records in main form and subform but duplicate first record for "subsubform" only
and give runtime error as following : Run time error 3078: The Microsoft Office Access database engine cannot find the input table or query. Make sure it exists and that the name is spelled correctly.
My knowledge in vba very limited i am a very bigger in VBA so that i need your help
what I need
- fix runtime error 3078
- complete duplicate records in "subsubform"
Thanks in advance kindly find below code
Private Sub cmdDuplicatePHIP_Click()
'Purpose: Duplicate the main form record and related records in the subform
Dim db As DAO.Database
Dim rstT2 As DAO.Recordset 'TRD_RDLog
Dim rstT2A As DAO.Recordset 'TRD_RDLog
Dim rstT3 As DAO.Recordset 'TFP_PHIPDtl
Dim rstT3A As DAO.Recordset 'TFP_PHIPDtl
Dim IngT1PK As Long ' current PK TRD_RDTrial
Dim IngT2PK As Long ' current PK TRD_RDLog
Dim IngT3PK As Long ' current PK TFP_PHIPDtl
Dim IngT1NewFK As Long ' new FK TRD_RDTrial
Dim IngT2NewFK As Long ' new FK TRD_RDLog
Dim IngT3NewFK As Long ' new FK TFP_PHIPDtl
Dim strSql As String 'SQL statement.
Dim strSql_S As String 'SQL statement.
Dim strSql_A As String 'SQL statement.
Dim msg As String
'records added
Dim intRC_CD As Integer 'TRD_RDTrial
Dim intRC_CS As Integer 'TRD_RDLog
Dim intRC_CA As Integer 'TFP_PHIPDtl
'Save and edits first
If Me.Dirty Then
Me.Dirty = False
End If
Set db = CurrentDb
'Make sure there is a record to duplicate.
If Me.NewRecord Then
MsgBox "Select the record to duplicate."
Else
'Duplicate the main record: add to form's clone.
'in TRD_RDTrial 1st table
IngT1PK = Me.TRPK
With Me.RecordsetClone
.AddNew
!TrialDate = Me.TrialDate
!TrialBy = Me.TrialBy
!QC = Me.QC
'etc for other fields.
.Update
intRC_CD = intRC_CD 1
'Save the primary key value, to use as the foreign key for the related records.
.Bookmark = .LastModified
IngT1NewFK = !TRPK
End With
'Duplicate the related records in TRD_RDLog 2nd table
'Select all records in TRD_RDLog
strSql_S = " SELECT TDPK, TRPK, RDCode, Kitchen, TrialPurpose, PHIPNetWt, ItemTrialNotes, SampleApproval, SampleApprovalDate, SampleApprovalNotes, RecipeDate, Notes"
strSql_S = strSql_S & " FROM [TRD_RDLog];"
Set rstT2A = db.OpenRecordset(strSql_S)
'Select the records to duplicate
strSql_S = " SELECT TDPK, RDCode, Kitchen, TrialPurpose, PHIPNetWt, ItemTrialNotes, SampleApproval, SampleApprovalDate, SampleApprovalNotes, RecipeDate, Notes"
strSql_S = strSql_S & " FROM [TRD_RDLog]"
strSql_S = strSql_S & " WHERE TRPK = " & IngT1PK & ";"
Set rstT2 = db.OpenRecordset(strSql_S)
'check for empty recordset
If Not rstT2.BOF And Not rstT2.EOF Then
rstT2.MoveLast
rstT2.MoveFirst
Do While Not rstT2.EOF
'save PK
IngT2PK = rstT2!TDPK
'add new record
With rstT2A
.AddNew
!TRPK = IngT1NewFK
!RDCode = Nz(rstT2!RDCode, "")
!Kitchen = Nz(rstT2!Kitchen, "")
!TrialPurpose = Nz(rstT2!TrialPurpose, "")
!PHIPNetWt = Nz(rstT2!PHIPNetWt, "")
!ItemTrialNotes = Nz(rstT2!ItemTrialNotes, "")
!SampleApproval = Nz(rstT2!SampleApproval, "")
!SampleApprovalDate = Nz(rstT2!SampleApprovalDate, "")
!SampleApprovalNotes = Nz(rstT2!SampleApprovalNotes, "")
!RecipeDate = Nz(rstT2!RecipeDate, "")
!Notes = Nz(rstT2!Notes, "")
'etc for other fields.
.Update
intRC_CS = intRC_CS 1
'get new PK
.Bookmark = .LastModified
IngT2NewFK = !TDPK ' new PK
End With
'Duplicate the related records in TFP_PHIPDtl (3rd table)
strSql_A = "SELECT IRF, TDPK, RawCode, Unit, PQty"
strSql_A = strSql_A & " FROM [TFP_PHIPDtl]"
Set rstT3A = db.OpenRecordset(strSql_A)
'Duplicate the related records in TFP_PHIPDtl (3rd table)
strSql_A = "SELECT IRF, RawCode, Unit, PQty"
strSql_A = strSql_A & " FROM [TFP_PHIPDtl]"
strSql_A = strSql_A & " WHERE TDPK = " & IngT2PK & ";"
Set rstT3 = db.OpenRecordset(strSql_A)
'check for empty recordset
If Not rstT3.BOF And Not rstT3.EOF Then
rstT3.MoveLast
rstT3.MoveFirst
Do While Not rstT3.EOF
'save PK
IngT3PK = rstT3!IRF
'add new record
With rstT3A
.AddNew
!TDPK = IngT2NewFK
!RawCode = Nz(rstT3!RawCode, "")
!Unit = Nz(rstT3!Unit, "")
!PQty = Nz(rstT3!PQty, "")
'etc for other fields.
.Update
intRC_CA = intRC_CA 1
'Save the primary key value, to use as the foreign key for the related records.
.Bookmark = .LastModified
IngT3NewFK = !IRF
End With
'insert record
db.Execute strSql, dbFailOnError
intRC_CA = intRC_CA 1
rstT3.MoveNext
Loop
rstT3.Close
rstT3A.Close
End If
rstT2.MoveNext
Loop
rstT2.Close
rstT2A.Close
End If
End If
'Display the new duplicate.
Me.FFP_PHIPLog.Visible = True
Me.Label186.Visible = True
Me.Label193.Visible = True
Me.Label200.Visible = True
Me.TrialDate.Locked = False
Me.TrialBy.Locked = False
Me.QC.Locked = False
Me.TrialDate.Value = Null
Me.TrialBy.Value = Null
Me.QC.Value = Null
'tell me when done
msg = intRC_CD & " record added to TRD_RDTrial"
msg = msg & vbCrLf & vbCrLf
msg = msg & intRC_CS & " record(s) added to TRD_RDLOG"
msg = msg & vbCrLf & vbCrLf
msg = msg & intRC_CA & " record(s) added to TFP_PHIPDTL"
msg = msg & vbCrLf & vbCrLf
msg = msg & "Total records added = " & intRC_CD intRC_CS intRC_CA
MsgBox msg
End Sub
CodePudding user response：
This is the full code to achieve this by clicking a button on the main form. The current record and all child records and child records of these will be copied in a snap to a new main record with child and childchild records, and the form will display this:
Private Sub CopyButton_Click()
Dim rst As DAO.Recordset
Dim rstAdd As DAO.Recordset
Dim rstSub As DAO.Recordset
Dim rstSubAdd As DAO.Recordset
Dim fld As DAO.Field
Dim Count As Integer
Dim CountSub As Integer
Dim Item As Integer
Dim ItemSub As Integer
Dim Bookmark As Variant
Dim OldId As Long
Dim NewId As Long
Dim NewSubId As Long
' Copy parent record.
Set rstAdd = Me.RecordsetClone
Set rst = rstAdd.Clone
' Move to current record.
rst.Bookmark = Me.Bookmark
OldId = rst!Id.Value
With rstAdd
.AddNew
For Each fld In .Fields
With fld
If .Attributes And dbAutoIncrField Then
' Skip Autonumber or GUID field.
Else
.Value = rst.Fields(.Name).Value
End If
End With
Next
.Update
' Pick Id of the new record.
.MoveLast
NewId = !Id.Value
End With
' Store location of new record.
Bookmark = rstAdd.Bookmark
' Copy child records.
' If a subform is present:
Set rstAdd = Me!subChild.Form.RecordsetClone
' If a subform is not present, retrieve records from the child table:
' Set rstAdd = CurrentDb.OpenRecordset("Select * From tblChild Where FK = " & OldId & "")
Set rst = rstAdd.Clone
If rstAdd.RecordCount > 0 Then
rstAdd.MoveLast
rstAdd.MoveFirst
End If
Count = rstAdd.RecordCount
For Item = 1 To Count
With rstAdd
.AddNew
For Each fld In .Fields
With fld
If .Attributes And dbAutoIncrField Then
' Skip Autonumber or GUID field.
ElseIf .Name = "FK" Then
' Skip master/child field.
.Value = NewId
Else
.Value = rst.Fields(.Name).Value
End If
End With
Next
.Update
' Pick Id of the new record.
.MoveLast
NewSubId = !Id.Value
End With
' Copy childchild records.
Set rstSubAdd = CurrentDb.OpenRecordset("Select * From tblChildChild Where FK = " & rst!Id.Value & "")
Set rstSub = rstSubAdd.Clone
If rstSubAdd.RecordCount > 0 Then
rstSubAdd.MoveLast
rstSubAdd.MoveFirst
End If
CountSub = rstSubAdd.RecordCount
For ItemSub = 1 To CountSub
With rstSubAdd
.AddNew
For Each fld In .Fields
With fld
If .Attributes And dbAutoIncrField Then
' Skip Autonumber or GUID field.
ElseIf .Name = "FK" Then
' Skip master/child field.
.Value = NewSubId
Else
.Value = rstSub.Fields(.Name).Value
End If
End With
Next
.Update
End With
rstSub.MoveNext
Next
rst.MoveNext
Next
rstSub.Close
rstSubAdd.Close
rst.Close
rstAdd.Close
' Move to the new recordcopy.
Me.Bookmark = Bookmark
Set fld = Nothing
Set rstAdd = Nothing
Set rst = Nothing
End Sub
The main challenge is, that while all child records are present in the subform, only one set of subchild records will be present. Thus, the subchild records must be retrieved from the subchild table/query, here named tblChildChild.
Also, primary key fields and foreign key fields are named Id and FK respectively. Adjust as needed.
To copy a single set of child-childchild records:
Private Sub CopyButton_Click()
Dim rst As DAO.Recordset
Dim rstAdd As DAO.Recordset
Dim fld As DAO.Field
Dim Bookmark As Variant
Dim Bookmark2 As Variant
Dim Bookmark3 As Variant
Dim NewId As Long
Dim NewSubId As Long
' Record current bookmarks of child and subchild.
Bookmark2 = Me!subChild.Form.Bookmark
Bookmark3 = Me!subChild.Form!subChildChild.Form.Bookmark
' Copy parent record.
Set rstAdd = Me.RecordsetClone
Set rst = rstAdd.Clone
' Move to current parent record.
rst.Bookmark = Me.Bookmark
With rstAdd
.AddNew
For Each fld In .Fields
With fld
If .Attributes And dbAutoIncrField Then
' Skip Autonumber or GUID field.
Else
.Value = rst.Fields(.Name).Value
End If
End With
Next
.Update
' Pick Id of the new record.
.MoveLast
NewId = !Id.Value
End With
' Store location of the new parent record.
Bookmark = rstAdd.Bookmark
' Copy child record.
Set rstAdd = Me!subChild.Form.RecordsetClone
Set rst = rstAdd.Clone
If rstAdd.RecordCount > 0 Then
' Move to current child record.
rst.Bookmark = Bookmark2
With rstAdd
.AddNew
For Each fld In .Fields
With fld
If .Attributes And dbAutoIncrField Then
' Skip Autonumber or GUID field.
ElseIf .Name = "FK" Then
' Skip master/child field.
.Value = NewId
Else
.Value = rst.Fields(.Name).Value
End If
End With
Next
.Update
' Pick Id of the new record.
.MoveLast
NewSubId = !Id.Value
End With
' Reposition child form.
Me!subChild.Form.Bookmark = Bookmark2
' Copy child child record.
Set rstAdd = Me!subChild.Form!subChildChild.Form.RecordsetClone
Set rst = rstAdd.Clone
If rstAdd.RecordCount > 0 Then
' Move to current child child record.
rst.Bookmark = Bookmark3
With rstAdd
.AddNew
For Each fld In .Fields
With fld
If .Attributes And dbAutoIncrField Then
' Skip Autonumber or GUID field.
ElseIf .Name = "FK" Then
' Skip master/child field.
.Value = NewSubId
Else
.Value = rst.Fields(.Name).Value
End If
End With
Next
.Update
End With
End If
End If
rst.Close
rstAdd.Close
' Move to the new record copy.
Me.Bookmark = Bookmark
Set fld = Nothing
Set rstAdd = Nothing
Set rst = Nothing
End Sub