Duplicate "one-to-many" Recordsets

[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

 

[KeithG]

Why do you want to duplicate records?

 

[jdcallejas]

Well it would be nice that besides complaining about the post being duplicate on both posts "which is not right to duplicate posts", help us get some answers.

I am interested in the same issue...

Thanks,

DaniBoy

 

[georgedwilkinson]

Keith just wanted to know why PC User was duplicating records, not why he was duplicating posts (it matters in how he would answer the question).

 

[Banana]

Seems to me you just need to repeat the same function for the many side table?

 

[jdcallejas]

Ohhh,

Now that you say it I can see... Sorry I appologize, for not understanding... sorry very much..

DaniBoy

 

[jdcallejas]

Hello, I thought about that!!!

But if you use the same code for the many table how will it know to relate with the parrent table?

DaniBoy

 

[georgedwilkinson]

Not sure this question can be answered correctly without the why. I'd just do it with copy/paste and be done with it. There must be a reason OP wants to do it the long way. So, why?

 

[jdcallejas]

Well, the reason for doing this in my case is so I dont have to create 250 invoices every month. I am creating a property management app. So if I can replicate all invoices I created the first time I wont have to input 250 invoices every first of the month every month.

Do you understand why I need this...?

DaniBoy

 

[Mike375]

I do it with a simple macro. I have a form based on a Many table where insurance policy options are entered and there could be several at one go for the same person and as you say most of the entries are the same.

I make the couple of changes and click a label that runs the little macro.

Since you can't paste in a macro here it is in code. As you can see there are a couple of other things being done as well. If I wanted heaps of copies in bulk then I would do a RunMacro for either a specified number of runs or stop running due to conditions.

DoCmd.RunCommand acCmdSaveRecord
DoCmd.RunCommand acCmdSelectRecord
DoCmd.RunCommand acCmdCopy
DoCmd.Close acForm, "ToLodgeSPPI"
DoCmd.OpenForm "ToLodgeSPPI", acNormal, "", "", acEdit, acNormal
DoCmd.GoToRecord , "", acNewRec
DoCmd.RunMacro "Macro44", , ""
DoCmd.RunCommand acCmdPasteAppend
Forms!ToLodgeSPPI!Label84.Visible = True
DoCmd.RunCommand acCmdSaveRecord

Probably if I was doing invoices I would have a field in the table that defaulted to Date() and a query would select last months and an append would fill 250 duplicated with the current date so they could pulled out.

 

[georgedwilkinson]

Yep, I get it. Makes perfect sense.

I always do this with a status record. I run a query (via VBA code) that identifies all the billable activity for the month (i.e. a property has been occupied this month) and creates a new Invoice status record with a value of "Ready to invoice". I (immediately) run a query off of that flag to build all the invoice records (it's really just a very small record, as records should be) and set the status to "Invoiced" when it is done, along with the date and so forth.

Duplicating tables is painful, so painful in fact, I wouldn't do it because it would take me too much time (including all the time that will be spent on maintenance). As such, I cannot provide an answer to your direct question since I'm just too lazy to do it for myself.

Sorry, maybe somebody who likes to work more than me has a solution.

 

[jdcallejas]

Thank you for the info

Hello and Thanks,

I like both suggestions.

I have some questions;

Mike, I see that you are running a macro on your code, what does that macro do?

George, I kind off understand what you are saying and I appologize for my ignorance. You say you do this with a Status Record, do you mean that there is a field on the table where you get your criteria to make the invoice? Than you say you run a query to identify billable activity for that month, how? I mean if I renten an apartment in january there only will be one activity for that month, after that there is no activities, the apartment is rented and all I need to do is invoices for it. So from what I understand I couldnt do this but only to the first month correct?

Thanks,

Daniboy

 

[georgedwilkinson]

Your query that sets a flag to invoice just needs to see if a property is rented (i.e. the ToDate has not been reached) and that it hasn't been invoiced this month.

 

[KeithG]

Well it would be nice that besides complaining about the post being duplicate on both posts "which is not right to duplicate posts", help us get some answers.

What is the point of being RUDE to someone trying to help? You need to learn some manners.

 

[jdcallejas]

Hello KeithG,

I had appologized about this above:

Ohhh,

Now that you say it I can see... Sorry I appologize, for not understanding... sorry very much..

DaniBoy

 

[Mike375]

Daniboy

It is just MoveSize. I use for all my forms in on open or whatever and put different numbers in for different screen resolutions so the forms are centred.

 

[PC User]

FYI,

I see that Allen Brown has an approach that works. I'll have to see if I can adapt it to the generic function that I have shown. This is Allen's dupication function: Duplicate the record in form and subform

~~PC

 

[PC User]

This is my first attempt to adapt Allen Brown's concept to the generic function and I'm getting this error:

Run-time error '3265':
Item not found in this collection

on this line of the code:

    Set tdf2 = db("SELECT * FROM strSubTable WHERE " & "idx.Indexes = " & varPKVal)

This is the code:

Function fCopyRecord(strMainTable As String, strSubTable As String, varPKVal) As Long
 
    Dim db As DAO.Database
    '  For main table
    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
    
    '  For subtable
    Dim qdf2 As DAO.QueryDef
    Dim tdf2 As DAO.TableDef
    Dim idx2 As DAO.Index
    Dim fld2 As DAO.Field
    Dim strPKName2 As String
    Dim strFields2 As String
    
    Dim intCount As Integer, intRecCount As Integer
    
    Set db = CurrentDb
    Set tdf = db(strMainTable)
    
        MsgBox "Your are about to duplicate the current record."
    
    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 [" & strMainTable & "] (" & strFields & ") " & _
            "SELECT " & strFields & " FROM [" & strMainTable & "] " & _
            "WHERE [" & strPKName & "]= " & varPKVal
    qdf.Execute
    If qdf.RecordsAffected > 0 Then
        With db.OpenRecordset("SELECT @@Identity")
            fCopyRecord = .Fields(0)
            .Close
        End With
    End If
    
        'Duplicate the related records: append query.
    Set tdf2 = db("SELECT * FROM strSubTable WHERE " & "idx.Indexes = " & varPKVal)
        
        If intRecCount = tdf2.RecordCount > 0 Then
      
            For Each idx2 In tdf2.Indexes
                If idx2.Primary Then
                    strPKName2 = idx.Fields(0).NAME
                    Exit For
                End If
            Next
            
            For Each fld2 In tdf2.Fields
                If fld2.NAME <> strPKName2 Then
                    strFields2 = strFields2 & ",[" & fld.NAME & "]"
                End If
            Next
            
            strFields2 = Mid(strFields, 2)
            Set qdf2 = db.CreateQueryDef("")
            
            qdf2.SQL = "INSERT INTO [" & strSubTable & "] (" & strFields2 & ") " & _
                    "SELECT " & strFields2 & " FROM [" & strSubTable & "] " & _
                    "WHERE [" & strPKName2 & "]= " & varPKVal
            qdf2.Execute
            If qdf2.RecordsAffected > 0 Then
                With db.OpenRecordset("SELECT @@Identity")
                    fCopyRecord = .Fields(0)
                    .Close
                End With
            End If
            Else
                MsgBox "Main record duplicated, but there were no related records."
        End If
    
    Set db = Nothing
    Set qdf = Nothing
    Set tdf = Nothing
    Set idx = Nothing
    Set fld = Nothing
    
    Set qdf2 = Nothing
    Set tdf2 = Nothing
    Set idx2 = Nothing
    Set fld2 = Nothing

End Function

Can someone help with this?
Thanks,

PC

 

[PC User]

I've further developed the code, but it's still not working. Can anyone help?

Option Compare Database
Option Explicit


    Dim db As DAO.Database
    '  For main table
    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
    
    '  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 rst As DAO.Recordset
    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 rst = db.OpenRecordset("SELECT * FROM " & gstrSubTable & " WHERE " & gvarMainPKVal & " = " & gvarExistingPKVal, dbOpenDynaset)

            ' The problem is obtaining a value for gvarSubPKVal
            Debug.Print gvarSubPKVal
            Debug.Print rst.Fields(gvarSubPKVal)
    
    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