Next the program parses the contents of the TextBox where you enter the field mappings. The mappings should have the form:

    source_field1 -> dest_field1
    source_field2 -> dest_field2
    source_field3 -> dest_field3
    ...

The program makes two arrays containing the corresponding source and destination field names.

After it has recorded all of the matching fields, the program loops through the source Recordset. For each record, it creates a new record in the destination Recordset and copies the values from the source fields into the destination fields.

Private Sub cmdCopy_Click()
Dim db As DAO.Database
Dim rs_fr As DAO.Recordset
Dim rs_to As DAO.Recordset
Dim mappings() As String
Dim mapping_line() As String
Dim name_fr As String
Dim name_to As String
Dim fields_fr() As DAO.Field
Dim fields_to() As DAO.Field
Dim field_fr As DAO.Field
Dim field_to As DAO.Field
Dim num_fields As Integer
Dim line_num As Integer
Dim i As Integer
Dim num_copied As Long

    ' Open the database.
    Set db = _
        DBEngine.Workspaces(0).OpenDatabase(txtDatabase.Text, _
        ReadOnly:=False)

    ' This example empties the "to" table before starting.
    ' You may or may not want this in a real application.
    db.Execute "DELETE FROM " & txtTableTo.Text

    ' Open the tables.
    Set rs_fr = db.OpenRecordset(txtTableFrom.Text, _
        dbOpenTable)
    Set rs_to = db.OpenRecordset(txtTableTo.Text, _
        dbOpenTable)

    ' Get the field mappings.
    num_fields = 0
    mappings = Split(txtFields.Text, vbCrLf)
    For line_num = LBound(mappings) To UBound(mappings)
        mapping_line = Split(mappings(line_num), "->")
        ' Make sure we have exactly 2 entries.
        If UBound(mapping_line) - LBound(mapping_line) <> 1 _
            Then
            name_fr = ""
            name_to = ""
        Else
            ' Get the field names.
            name_fr = _
                Trim$(mapping_line(LBound(mapping_line)))
            name_to = _
                Trim$(mapping_line(UBound(mapping_line)))
        End If

        ' Make sure we have two field names.
        If Len(name_fr) > 0 And Len(name_to) > 0 Then
            ' Get the corresponding field objects.
            On Error Resume Next
            Set field_fr = rs_fr.Fields(name_fr)
            If Err.Number <> 0 Then Set field_fr = Nothing
            Set field_to = rs_to.Fields(name_to)
            If Err.Number <> 0 Then Set field_to = Nothing
            Err.Clear
            On Error GoTo 0
        End If

        ' If the field objects are not Nothing, then save
        ' them.
        If Not ((field_fr Is Nothing) Or (field_to Is _
            Nothing)) Then
            num_fields = num_fields + 1
            ReDim Preserve fields_fr(1 To num_fields)
            ReDim Preserve fields_to(1 To num_fields)
            Set fields_fr(num_fields) = field_fr
            Set fields_to(num_fields) = field_to
        End If
    Next line_num

    ' Copy the records.
    num_copied = 0
    Do Until rs_fr.EOF
        ' Make a new record.
        rs_to.AddNew

        ' Copy the field values.
        For i = 1 To num_fields
            fields_to(i).Value = fields_fr(i).Value
        Next i
        rs_to.Update

        rs_fr.MoveNext
        num_copied = num_copied + 1
    Loop

    rs_fr.Close
    rs_to.Close
    db.Close

    MsgBox "Copied " & num_copied & " records"
End Sub