Копирование данных записи из одной таблицы в другую, аналогичную по структуре (DAO)

Private Sub CopyRecords(bToArchive As Boolean)
'Копирование данных записи из одной таблицы в другую, аналогичную по структуре (DAO)
' + Поле Attachment
'--------------------------------------------------------------------------
Dim sSRC As String, sDST As String, vVal
Dim rsSRC As DAO.Recordset
Dim rsDST As DAO.Recordset
Dim rsAttachmentsSRC As DAO.Recordset
Dim rsAttachmentsDST As DAO.Recordset
Dim objFieldAtt As DAO.Field

Dim objField As DAO.Field
Dim sRefTable$

On Error GoTo CopyRecords_Err
    
    If bToArchive = False Then
        sSRC = "SELECT Код, ФИО, Возраст, Пол, Фото FROM [Таблица (Архив)] WHERE (ПолеВыбора = True);"
        sDST = "SELECT Код, ФИО, Возраст, Пол, Фото FROM [Таблица (Главная)]"
        sRefTable = "[Таблица (Главная)]"
    Else
        sSRC = "SELECT Код, ФИО, Возраст, Пол, Фото FROM [Таблица (Главная)] WHERE (ВАрхив = True);"
        sDST = "SELECT Код, ФИО, Возраст, Пол, Фото FROM [Таблица (Архив)]"
        sRefTable = "[Таблица (Архив)]"
    
    End If
    
    Set rsSRC = CurrentDb.OpenRecordset(sSRC, dbOpenSnapshot) 'Источник - Только просмотр
    Set rsDST = CurrentDb.OpenRecordset(sDST, dbOpenDynaset)  'Назначение (куда)
    
    
    Do Until rsSRC.EOF = True 'Цикл до конца набора
        vVal = Nz(DLookup("Код", sRefTable, "Код = " & rsSRC!Код), 0)
        If vVal = 0 Then
            With rsDST
                .AddNew
                For Each objField In .Fields
                    If Not objField.Name = "Фото" Then
                        objField.Value = rsSRC(objField.Name)
                    Else
                        Set rsAttachmentsSRC = rsSRC!Фото.Value
                        Set rsAttachmentsDST = rsDST!Фото.Value
                        Do While Not rsAttachmentsSRC.EOF
                            rsAttachmentsDST.AddNew
                                rsAttachmentsDST!FileData = rsAttachmentsSRC!FileData
                                rsAttachmentsDST!FileName = rsAttachmentsSRC!FileName
                            rsAttachmentsDST.Update
                            
                            rsAttachmentsSRC.MoveNext
                        Loop
                    End If
                Next
                .Update
            End With
        End If
        rsSRC.MoveNext
    Loop


CopyRecords_End:
    On Error Resume Next
    
    Set objField = Nothing
    Set objFieldAtt = Nothing
    
    rsSRC.Close:    Set rsSRC = Nothing
    rsDST.Close:    Set rsDST = Nothing
    
    rsAttachmentsSRC.Close
    Set rsAttachmentsSRC = Nothing
    
    rsAttachmentsDST.Close
    Set rsAttachmentsDST = Nothing

    
    Err.Clear
    Exit Sub

CopyRecords_Err:
    MsgBox "Error: " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in Sub: CopyRecords in module: []", vbCritical, "Error in Application"
    Resume CopyRecords_End
End Sub

Ещё вариант:

Private Sub CopyRecordToLog(vRecordID As Variant)
'Копирование данных записи из одной таблицы в другую, аналогичную по структуре (DAO)
'Аргумент = vRecordID = Номер записи по счётчику
'--------------------------------------------------------------------------
'... Тут из таблицы "DataTest" в неё-же, у которой поле "RecIDAuto" уникальный индекс типа счётчик
'--------------------------------------------------------------------------
Dim s As String
Dim rsSRC As DAO.Recordset
Dim rsDST As DAO.Recordset
Dim objField As DAO.Field
Dim l As Long
On Error GoTo CopyRecordToLog_Err
    
    s = "Select * From DataTest WHERE RecIDAuto=" & vRecordID
    Set rsSRC = CurrentDb.OpenRecordset(s, dbOpenSnapshot)  'Источник (одна запись) Только просмотр
    
    Set rsDST = CurrentDb.OpenRecordset("DataTest", dbOpenDynaset) 'Назначение (куда)
    
    With rsDST
        .AddNew
        For Each objField In .Fields
            'Проверка что полле не счётчик (по известному названию)
            If objField.Name <> "RecIDAuto" Then 'Поле не счётчик
                objField.Value = rsSRC(objField.Name).Value
            End If
        Next
        l = !RecIDAuto
        .Update
        MsgBox "Добавлена запись ID: " & l
    End With
   

CopyRecordToLog_End:
    On Error Resume Next
    Set objField = Nothing
    rsSRC.Close
    Set rsSRC = Nothing
    rsDST.Close
    Set rsDST = Nothing
    
    Err.Clear
    Exit Sub

CopyRecordToLog_Err:
    MsgBox "Error: " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in Sub: CopyRecordToLog in module: 00ModuleForTests", vbCritical, "Error in Application"
    Resume CopyRecordToLog_End
End Sub