How To Duplicate "one-to-many" Recordsets

P

PC User

I have a functional function that can duplicate a record so that I can
edit a specific field and not have to enter all the data for all the
fields in a new record. However, now I have a table that is in a one-
to-many relationship with another table and this function will only
duplicate the "one' table. As for the "many" table, I'm looking for
ideas to approach this problem or maybe someone already has a function
that can do this. The function that I have working for the "one"
table is as follows:
===================================================
Function fCopyRecord(strTable As String, varPKVal) As Long
'Copies a record in a specified table
'Accepts table name and Primary key value.
'Currently assumes a simplistic single PK field

'The fairly generic function below will add a copy of a record to the
same table
'based on an existing PK value and return the PK value of the new
record.
'You could then use similar code to create the child records.

Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim tdf As DAO.TableDef
Dim idx As DAO.Index
Dim fld As DAO.Field
Dim strPKName As String
Dim strFields As String

Set db = CurrentDb
Set tdf = db(strTable)

For Each idx In tdf.Indexes
If idx.Primary Then
strPKName = idx.Fields(0).Name
Exit For
End If
Next

For Each fld In tdf.Fields
If fld.Name <> strPKName Then
strFields = strFields & ",[" & fld.Name & "]"
End If
Next
strFields = Mid(strFields, 2)

Set qdf = db.CreateQueryDef("")

qdf.SQL = "INSERT INTO [" & strTable & "] (" & strFields & ") " &
_
"SELECT " & strFields & " FROM [" & strTable & "] " & _
"WHERE [" & strPKName & "]= " & varPKVal
qdf.Execute
If qdf.RecordsAffected > 0 Then
With db.OpenRecordset("SELECT @@Identity")
fCopyRecord = .Fields(0)
.Close
End With
End If

Set db = Nothing
Set qdf = Nothing
Set tdf = Nothing
Set idx = Nothing
Set fld = Nothing

End Function
===================================================
Any help on this will be appreciated.
Thanks,

PC
 
P

PC User

I got a little further in working out the code and I was wondering if
someone can help me on this?

I get an error

====
Run-time error '3265'
Item not found in this collection
====
on the line:
====
Set tdf2 = db(strSQL)
====

'==================================
Option Compare Database
Option Explicit


'Parameters for queries
Dim strSelect As String, strFrom As String
Dim strJoin As String, strWhere As String
Dim strOrderBy As String, strSQL As String
'Parameters for recordset
Dim db As DAO.Database
Dim tblDef As DAO.TableDef
Dim rst As DAO.Recordset
' For main table
Dim qdf As DAO.QueryDef
Dim tdf As DAO.TableDef
Dim tdf1 As DAO.TableDef
Dim tdf2 As DAO.TableDef
Dim idx As DAO.Index
Dim fld As DAO.Field
Dim strPKName As String
Dim strFields As String
' For subtable
Dim qfdsub As DAO.QueryDef
Dim tdfsub As DAO.TableDef
Dim idxsub As DAO.Index
Dim fldsub As DAO.Field
Dim strPKsubName As String
Dim strSubFields As String

Dim strInserts As String
Dim lngNewItem As Long
'Dim lngExistingID As Long
'Dim lngNewID As Long

' For tables
Public gstrMainTable As String
Public gstrSubTable As String

' For primary keys in tables
Public gvarMainPKVal As Long
Public gvarSubPKVal As Long
Public gvarExistingPKVal As Long
Public gvarNewPKVal As Long
Public gstrSubFieldName As String
Public gvarSubFieldNewVal As Long

'=====================================================
'=====================================================
'=====================================================

Function fCopyRelationalRecord(varMainPKVal As Long) As Long

'Create copy of parent Job record
gvarNewPKVal = fCopyMainRecord()
gvarMainPKVal = varMainPKVal
gvarExistingPKVal = gvarMainPKVal

'Call fCopyItems(gvarMainPKVal, gvarNewPKVal)
Call fCopySubRecord

fCopyRelationalRecord = gvarNewPKVal

MsgBox "Copy complete", vbInformation

End Function

'=====================================================
' The function below duplicates the primary record
'=====================================================

Function fCopyMainRecord() As Long
'Copies a record in a specified table
'Accepts table name and Primary key value.
'Currently assumes a single PK field

Set db = CurrentDb
Set tdf = db(gstrMainTable)

For Each idx In tdf.Indexes
If idx.Primary Then
strPKName = idx.Fields(0).Name
Exit For
End If
Next

For Each fld In tdf.Fields
If fld.Name <> strPKName Then
strFields = strFields & ",[" & fld.Name & "]"
End If
Next
strFields = Mid(strFields, 2)

Set qdf = db.CreateQueryDef("")

qdf.SQL = "INSERT INTO [" & gstrMainTable & "] (" & strFields & ")
" & _
"SELECT " & strFields & " FROM [" & gstrMainTable & "] " &
_
"WHERE [" & strPKName & "]= " & gvarMainPKVal
qdf.Execute
If qdf.RecordsAffected > 0 Then
With db.OpenRecordset("SELECT @@Identity")
fCopyMainRecord = .Fields(0)
.Close
End With
End If
Debug.Print fCopyMainRecord

Set db = Nothing
Set qdf = Nothing
Set tdf = Nothing
Set idx = Nothing
Set fld = Nothing

End Function

'=====================================================
' The function below duplicates related items in the subtable linked
' to the primary record.
'=====================================================

Function fCopySubRecord() ' Code taken from fCopyItems
Set db = CurrentDb
Set tdf1 = db(gstrSubTable)

strSQL = "SELECT * FROM " & gstrSubTable & " WHERE " &
gvarMainPKVal & " = " & gvarExistingPKVal
Set rst = db.OpenRecordset(strSQL, dbOpenDynaset)
Set tdf2 = db(strSQL)

'Debug.Print rst.Fields(gvarSubPKVal)

For Each idx In tdf2.Indexes
If idx.Primary Then
gvarSubPKVal = idx.Fields(0).Name
Debug.Print gvarSubPKVal
Call fCopyChildRecord(rst.Fields(gvarSubPKVal))
Exit For
End If
Next

'With rst
' Do Until .EOF
' Call fCopyChildRecord(.Fields(gvarSubPKVal))
' .MoveNext
' Loop
' .Close
'End With

Set rst = Nothing
Set db = Nothing
End Function

'=====================================================
' The function below enters data into each field of a record in the
subtable
'=====================================================

Function fCopyChildRecord(varSubFieldNewVal) As Long
'Copies record in a specified table based on passed field
'Currently assumes a single field

Set db = CurrentDb
Set tdf = db(gstrSubTable)
gvarSubFieldNewVal = varSubFieldNewVal

For Each idx In tdf.Indexes
If idx.Primary Then
strPKName = idx.Fields(0).Name
Exit For
End If
Next

For Each fld In tdf.Fields
If fld.Name <> strPKName Then
strFields = strFields & ",[" & fld.Name & "]"
If fld.Name = gstrSubFieldName Then
strInserts = strInserts & ",'" & gvarSubFieldNewVal &
"'"
Else
strInserts = strInserts & ",[" & fld.Name & "]"
End If
End If
Next
strFields = Mid(strFields, 2)
strInserts = Mid(strInserts, 2)

Set qdf = db.CreateQueryDef("")

qdf.SQL = "INSERT INTO [" & gstrSubTable & "] (" & strFields & ")
" & _
"SELECT " & strInserts & " FROM [" & gstrSubTable & "] " &
_
"WHERE [" & strPKName & "]= " & gvarSubPKVal
qdf.Execute
If qdf.RecordsAffected > 0 Then
With db.OpenRecordset("SELECT @@Identity")
fCopyChildRecord = .Fields(0)
.Close
End With
End If

Set db = Nothing
Set qdf = Nothing
Set tdf = Nothing
Set idx = Nothing
Set fld = Nothing

End Function
'==================================

Thanks,

PC
 
J

Jeff Boyce

I think you have to create a tabledef... Check Access help on TableDef.

Regards

Jeff Boyce
Microsoft Office/Access MVP

PC User said:
I got a little further in working out the code and I was wondering if
someone can help me on this?

I get an error

====
Run-time error '3265'
Item not found in this collection
====
on the line:
====
Set tdf2 = db(strSQL)
====

'==================================
Option Compare Database
Option Explicit


'Parameters for queries
Dim strSelect As String, strFrom As String
Dim strJoin As String, strWhere As String
Dim strOrderBy As String, strSQL As String
'Parameters for recordset
Dim db As DAO.Database
Dim tblDef As DAO.TableDef
Dim rst As DAO.Recordset
' For main table
Dim qdf As DAO.QueryDef
Dim tdf As DAO.TableDef
Dim tdf1 As DAO.TableDef
Dim tdf2 As DAO.TableDef
Dim idx As DAO.Index
Dim fld As DAO.Field
Dim strPKName As String
Dim strFields As String
' For subtable
Dim qfdsub As DAO.QueryDef
Dim tdfsub As DAO.TableDef
Dim idxsub As DAO.Index
Dim fldsub As DAO.Field
Dim strPKsubName As String
Dim strSubFields As String

Dim strInserts As String
Dim lngNewItem As Long
'Dim lngExistingID As Long
'Dim lngNewID As Long

' For tables
Public gstrMainTable As String
Public gstrSubTable As String

' For primary keys in tables
Public gvarMainPKVal As Long
Public gvarSubPKVal As Long
Public gvarExistingPKVal As Long
Public gvarNewPKVal As Long
Public gstrSubFieldName As String
Public gvarSubFieldNewVal As Long

'=====================================================
'=====================================================
'=====================================================

Function fCopyRelationalRecord(varMainPKVal As Long) As Long

'Create copy of parent Job record
gvarNewPKVal = fCopyMainRecord()
gvarMainPKVal = varMainPKVal
gvarExistingPKVal = gvarMainPKVal

'Call fCopyItems(gvarMainPKVal, gvarNewPKVal)
Call fCopySubRecord

fCopyRelationalRecord = gvarNewPKVal

MsgBox "Copy complete", vbInformation

End Function

'=====================================================
' The function below duplicates the primary record
'=====================================================

Function fCopyMainRecord() As Long
'Copies a record in a specified table
'Accepts table name and Primary key value.
'Currently assumes a single PK field

Set db = CurrentDb
Set tdf = db(gstrMainTable)

For Each idx In tdf.Indexes
If idx.Primary Then
strPKName = idx.Fields(0).Name
Exit For
End If
Next

For Each fld In tdf.Fields
If fld.Name <> strPKName Then
strFields = strFields & ",[" & fld.Name & "]"
End If
Next
strFields = Mid(strFields, 2)

Set qdf = db.CreateQueryDef("")

qdf.SQL = "INSERT INTO [" & gstrMainTable & "] (" & strFields & ")
" & _
"SELECT " & strFields & " FROM [" & gstrMainTable & "] " &
_
"WHERE [" & strPKName & "]= " & gvarMainPKVal
qdf.Execute
If qdf.RecordsAffected > 0 Then
With db.OpenRecordset("SELECT @@Identity")
fCopyMainRecord = .Fields(0)
.Close
End With
End If
Debug.Print fCopyMainRecord

Set db = Nothing
Set qdf = Nothing
Set tdf = Nothing
Set idx = Nothing
Set fld = Nothing

End Function

'=====================================================
' The function below duplicates related items in the subtable linked
' to the primary record.
'=====================================================

Function fCopySubRecord() ' Code taken from fCopyItems
Set db = CurrentDb
Set tdf1 = db(gstrSubTable)

strSQL = "SELECT * FROM " & gstrSubTable & " WHERE " &
gvarMainPKVal & " = " & gvarExistingPKVal
Set rst = db.OpenRecordset(strSQL, dbOpenDynaset)
Set tdf2 = db(strSQL)

'Debug.Print rst.Fields(gvarSubPKVal)

For Each idx In tdf2.Indexes
If idx.Primary Then
gvarSubPKVal = idx.Fields(0).Name
Debug.Print gvarSubPKVal
Call fCopyChildRecord(rst.Fields(gvarSubPKVal))
Exit For
End If
Next

'With rst
' Do Until .EOF
' Call fCopyChildRecord(.Fields(gvarSubPKVal))
' .MoveNext
' Loop
' .Close
'End With

Set rst = Nothing
Set db = Nothing
End Function

'=====================================================
' The function below enters data into each field of a record in the
subtable
'=====================================================

Function fCopyChildRecord(varSubFieldNewVal) As Long
'Copies record in a specified table based on passed field
'Currently assumes a single field

Set db = CurrentDb
Set tdf = db(gstrSubTable)
gvarSubFieldNewVal = varSubFieldNewVal

For Each idx In tdf.Indexes
If idx.Primary Then
strPKName = idx.Fields(0).Name
Exit For
End If
Next

For Each fld In tdf.Fields
If fld.Name <> strPKName Then
strFields = strFields & ",[" & fld.Name & "]"
If fld.Name = gstrSubFieldName Then
strInserts = strInserts & ",'" & gvarSubFieldNewVal &
"'"
Else
strInserts = strInserts & ",[" & fld.Name & "]"
End If
End If
Next
strFields = Mid(strFields, 2)
strInserts = Mid(strInserts, 2)

Set qdf = db.CreateQueryDef("")

qdf.SQL = "INSERT INTO [" & gstrSubTable & "] (" & strFields & ")
" & _
"SELECT " & strInserts & " FROM [" & gstrSubTable & "] " &
_
"WHERE [" & strPKName & "]= " & gvarSubPKVal
qdf.Execute
If qdf.RecordsAffected > 0 Then
With db.OpenRecordset("SELECT @@Identity")
fCopyChildRecord = .Fields(0)
.Close
End With
End If

Set db = Nothing
Set qdf = Nothing
Set tdf = Nothing
Set idx = Nothing
Set fld = Nothing

End Function
'==================================

Thanks,

PC
Click to expand...
 
D

Douglas J. Steele

The only thing strSQL can be in that case is the name of a table.

--
Doug Steele, Microsoft Access MVP

(no e-mails, please!)


PC User said:
I got a little further in working out the code and I was wondering if
someone can help me on this?

I get an error

====
Run-time error '3265'
Item not found in this collection
====
on the line:
====
Set tdf2 = db(strSQL)
====

'==================================
Option Compare Database
Option Explicit


'Parameters for queries
Dim strSelect As String, strFrom As String
Dim strJoin As String, strWhere As String
Dim strOrderBy As String, strSQL As String
'Parameters for recordset
Dim db As DAO.Database
Dim tblDef As DAO.TableDef
Dim rst As DAO.Recordset
' For main table
Dim qdf As DAO.QueryDef
Dim tdf As DAO.TableDef
Dim tdf1 As DAO.TableDef
Dim tdf2 As DAO.TableDef
Dim idx As DAO.Index
Dim fld As DAO.Field
Dim strPKName As String
Dim strFields As String
' For subtable
Dim qfdsub As DAO.QueryDef
Dim tdfsub As DAO.TableDef
Dim idxsub As DAO.Index
Dim fldsub As DAO.Field
Dim strPKsubName As String
Dim strSubFields As String

Dim strInserts As String
Dim lngNewItem As Long
'Dim lngExistingID As Long
'Dim lngNewID As Long

' For tables
Public gstrMainTable As String
Public gstrSubTable As String

' For primary keys in tables
Public gvarMainPKVal As Long
Public gvarSubPKVal As Long
Public gvarExistingPKVal As Long
Public gvarNewPKVal As Long
Public gstrSubFieldName As String
Public gvarSubFieldNewVal As Long

'=====================================================
'=====================================================
'=====================================================

Function fCopyRelationalRecord(varMainPKVal As Long) As Long

'Create copy of parent Job record
gvarNewPKVal = fCopyMainRecord()
gvarMainPKVal = varMainPKVal
gvarExistingPKVal = gvarMainPKVal

'Call fCopyItems(gvarMainPKVal, gvarNewPKVal)
Call fCopySubRecord

fCopyRelationalRecord = gvarNewPKVal

MsgBox "Copy complete", vbInformation

End Function

'=====================================================
' The function below duplicates the primary record
'=====================================================

Function fCopyMainRecord() As Long
'Copies a record in a specified table
'Accepts table name and Primary key value.
'Currently assumes a single PK field

Set db = CurrentDb
Set tdf = db(gstrMainTable)

For Each idx In tdf.Indexes
If idx.Primary Then
strPKName = idx.Fields(0).Name
Exit For
End If
Next

For Each fld In tdf.Fields
If fld.Name <> strPKName Then
strFields = strFields & ",[" & fld.Name & "]"
End If
Next
strFields = Mid(strFields, 2)

Set qdf = db.CreateQueryDef("")

qdf.SQL = "INSERT INTO [" & gstrMainTable & "] (" & strFields & ")
" & _
"SELECT " & strFields & " FROM [" & gstrMainTable & "] " &
_
"WHERE [" & strPKName & "]= " & gvarMainPKVal
qdf.Execute
If qdf.RecordsAffected > 0 Then
With db.OpenRecordset("SELECT @@Identity")
fCopyMainRecord = .Fields(0)
.Close
End With
End If
Debug.Print fCopyMainRecord

Set db = Nothing
Set qdf = Nothing
Set tdf = Nothing
Set idx = Nothing
Set fld = Nothing

End Function

'=====================================================
' The function below duplicates related items in the subtable linked
' to the primary record.
'=====================================================

Function fCopySubRecord() ' Code taken from fCopyItems
Set db = CurrentDb
Set tdf1 = db(gstrSubTable)

strSQL = "SELECT * FROM " & gstrSubTable & " WHERE " &
gvarMainPKVal & " = " & gvarExistingPKVal
Set rst = db.OpenRecordset(strSQL, dbOpenDynaset)
Set tdf2 = db(strSQL)

'Debug.Print rst.Fields(gvarSubPKVal)

For Each idx In tdf2.Indexes
If idx.Primary Then
gvarSubPKVal = idx.Fields(0).Name
Debug.Print gvarSubPKVal
Call fCopyChildRecord(rst.Fields(gvarSubPKVal))
Exit For
End If
Next

'With rst
' Do Until .EOF
' Call fCopyChildRecord(.Fields(gvarSubPKVal))
' .MoveNext
' Loop
' .Close
'End With

Set rst = Nothing
Set db = Nothing
End Function

'=====================================================
' The function below enters data into each field of a record in the
subtable
'=====================================================

Function fCopyChildRecord(varSubFieldNewVal) As Long
'Copies record in a specified table based on passed field
'Currently assumes a single field

Set db = CurrentDb
Set tdf = db(gstrSubTable)
gvarSubFieldNewVal = varSubFieldNewVal

For Each idx In tdf.Indexes
If idx.Primary Then
strPKName = idx.Fields(0).Name
Exit For
End If
Next

For Each fld In tdf.Fields
If fld.Name <> strPKName Then
strFields = strFields & ",[" & fld.Name & "]"
If fld.Name = gstrSubFieldName Then
strInserts = strInserts & ",'" & gvarSubFieldNewVal &
"'"
Else
strInserts = strInserts & ",[" & fld.Name & "]"
End If
End If
Next
strFields = Mid(strFields, 2)
strInserts = Mid(strInserts, 2)

Set qdf = db.CreateQueryDef("")

qdf.SQL = "INSERT INTO [" & gstrSubTable & "] (" & strFields & ")
" & _
"SELECT " & strInserts & " FROM [" & gstrSubTable & "] " &
_
"WHERE [" & strPKName & "]= " & gvarSubPKVal
qdf.Execute
If qdf.RecordsAffected > 0 Then
With db.OpenRecordset("SELECT @@Identity")
fCopyChildRecord = .Fields(0)
.Close
End With
End If

Set db = Nothing
Set qdf = Nothing
Set tdf = Nothing
Set idx = Nothing
Set fld = Nothing

End Function
'==================================

Thanks,

PC
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

SELECT INTO to text file 60
could any one explain this code for me ? 0
How do you create joint PKs using VBA? 3
Too Many Indexes Error 3
Cant see table data 12
Please Help!! Error 3111 7
Creating relations between linked tables. 2
Copy record into same table 1

Top