Copy / Duplicate Records & Sub-Records

Below is an example of my table information:

PK = Primary Key / Unique Identifier (this example they are autonumbers)
FK = Foreign Key

Main Table
(tbl_Main)
Main_ID_PK
Field_01
Field_02
Field_03
Field_04
Field_05

Sub Table A
(tbl_sub_A)
A_ID_PK
Main_ID_FK
aField_01
aField_02

Sub Table B
(tbl_sub_B)
B_ID_PK
Main_ID_FK
bField_01
bField_02

Sub-Sub Table BB
(tbl_subsub_BB)
BB_ID_PK
B_ID_FK
bbField_01
bbField_02

Below is an example of my code:
 

'The 1st 2 lines (Option Explicit & Option Compare Database) are at the beginning of the module
Option Explicit
Option Compare Database

Private Sub cmd_Duplicate_All_Click()

'Declare variables.
Dim db As Database
Dim rec As Recordset
Dim rec2 As Recordset

Dim strSQL As String
Dim strSQL1 As String
Dim strSQL2 As String
Dim strSQL3 As String
Dim strSQL4 As String
Dim strSQL5 As String
Dim strSQL6 As String
Dim strSQL7 As String
Dim strSQL8 As String
Dim strSQL9 As String
Dim strSQL10 As String
Dim strSQL11 As String
Dim strSQL12 As String
Dim strSQL13 As String
Dim strSQL14 As String
Dim strSQL15 As String
Dim strSQL16 As String
Dim strSQL17 As String
Dim strSQL18 As String
Dim strSQL19 As String

Dim NewMainID As Long
Dim OldMainID As Long
Dim NewSubID As Long

Set db = CurrentDb()
Set rec = db.OpenRecordset("tbl_Main")
Set rec2 = db.OpenRecordset("tbl_sub_B")

'Store Main "to be copied" record's primary key in variable.
OldMainID = Me.Main_ID_PK

'Insert record into Main table.
strSQL1 = "INSERT INTO tbl_Main (Field_01, Field_02, Field_03, Field_04, Field_05) "
strSQL2 = "Select tbl_Main.Field_01, tbl_Main.Field_02, tbl_Main.Field_03, tbl_Main.Field_04, "tbl_Main.Field_05 "
strSQL4 = "FROM tbl_Main WHERE (((Main_ID_PK)=" & OldMainID & "));"
strSQL = strSQL1 & strSQL2 & strSQL4
db.Execute strSQL, dbFailOnError

With rec
.MoveFirst
.MoveLast
End With

'Store newly created Main table record's primary key in variable.
NewMainID = rec("Main_ID_PK")

'Insert records into Sub Table A.
strSQL5 = "INSERT INTO tbl_sub_A ( [aField_01], [aField_02], Main_ID_FK) "
strSQL6 = "SELECT tbl_sub_A.[aField_01], tbl_sub_A.[aField_02], "
strSQL7 = [NewMainID]
strSQL8 = " FROM [tbl_sub_A] WHERE (((tbl_sub_A.Main_ID_FK)=" & OldMainID & "));"
strSQL9 = strSQL5 & strSQL6 & strSQL7 & strSQL8
db.Execute strSQL9, dbFailOnError

'Insert records into Sub Table B.
strSQL10 = "INSERT INTO tbl_sub_B ( [bField_01], [bField_02], Main_ID_FK) "
strSQL11 = "SELECT tbl_sub_B.[bField_01], tbl_sub_B.[bField_02], "
strSQL12 = [NewMainID]
strSQL13 = " FROM [tbl_sub_B] WHERE (((tbl_sub_B.Main_ID_FK)=" & OldMainID & "));"
strSQL14 = strSQL10 & strSQL11 & strSQL12 & strSQL13
db.Execute strSQL14, dbFailOnError

With rec2
.MoveFirst
.MoveLast
End With

'Store newly created Invoice record's primary key in variable.
NewSubID = rec2("B_ID_PK")

'Insert records into Sub-Sub Table BB.
strSQL15 = "INSERT INTO tbl_subsub_BB( [bbField_01], [bbField_02], B_ID_FK) "
strSQL16 = "SELECT tbl_subsub_BB.[bbField_01], tbl_subsub_BB.[bbField_02], "
strSQL17 = [NewSubID]
strSQL18 = " FROM (tbl_Main LEFT JOIN tbl_sub_B ON tbl_Main.Main_ID_PK = tbl_sub_B.Main_ID_FK) LEFT JOIN tbl_subsub_BB ON tbl_sub_B.B_ID_PK = tbl_subsub_BB.B_ID_FK WHERE (((tbl_Main.Main_ID_PK)=" & OldMainID & "));"
strSQL19 = strSQL15 & strSQL16 & strSQL17 & strSQL18
db.Execute strSQL19, dbFailOnError

'Refreshes the data on the form.
Me.Requery

'Puts focus on newly created Contract record (the last record).
DoCmd.RunCommand acCmdRecordsGoToLast

End Sub

Select allOpen in new window

This works fine when the relationship between the Parent table & the Child table is 1:1.  But if the relationship between the Parent table & the Child table is 1:many, then the Grandchild table entries are incorrect.

I can see why this is happening.  The NewSubID being inserted into the B_ID_FK field for all copied Grandchild records is using the same number (so all the newly created Sub Sub BB records are being associated with just one newly created Sub B record).  Since there is more than one record being added to the Sub Table B, there should be more than one number B_ID_FK used.

I believe the problem is starting at “Insert records into Sub Table B”.  I think this needs to be looped through so the individual NewSubID’s are captured.  Bear with me here… so the process would be:

1. Grab the 1st Sub Table B record to be copied (OldSubID).

2. Copy it’s info into the new Sub Table B record & store it’s ID (NewSubID).

3. Grab all the Sub-Sub Table BB’s record using the OldSubID & copy the entries using the NewSubID.

4. Loop back to grab the 2nd Sub Table B record to be copied (OldSubID updated) & go through the process again until EOF (end of file) / no more Sub Table B records to copy for the Main table.

I am unsure how to code this in VBA.  Any assistance is greatly appreciated.

I too, will answer in sections.

First this code is unreliable:

With rec
.MoveFirst
.MoveLast
End With

'Store newly created Main table record's primary key in variable.
NewMainID = rec("Main_ID_PK")


Please change to this:

.Move 0, .LastModified ' [1]
'Store newly created Main table record's primary key in variable.
NewMainID = rec("Main_ID_PK")


While you are doing that I will work on your recursive loops

Correction: Please change to this:

rec.Move 0, rec.LastModified ' [1]
'Store newly created Main table record's primary key in variable.
NewMainID = rec!Main_ID_PK


And later on:
rec2.Move 0, rec2.LastModified ' [1]
'Store newly created child table record's primary key in variable.
NewMainID = rec2!B_ID_PK

I'm sorry, stop.  In my rush to get out a quick answer, I've mis-led you.  This will be a complicated re-write, so let me get back to you soon

Ok.  :)   Thanks.

Thank you for responding so quickly.  Let me work with what you gave me & will post back.

Also, I caution you that my code is devoid of any error handling, so that will need to be added.  And...the entire procedure should be inside a transaction so that the copy either succeeds or fails as a whole.  

That worked great!  Thanks!!

I will work on the error handling.

Great solution!  And very fast response.  :)