نسخ بيانات جدول في قاعدة بيانات الى جدول آخر في قاعدة بيانات أخرى وفق شرط معين

Dim Db1 As Database, Db2 As Database
Dim RS1 As Recordset, RS2 As Recordset
Dim SQL As String
Dim FLD As Field
Dim I As Byte
Set Db1 = OpenDatabase("database1")
'هو إسم قاعدة البيانات الاولى database1 حيث
Set Db2 = OpenDatabase("database2")
'هو إسم قاعدة البيانات الثانيه database2 حيث
SQL = "Select * From Table1 where Field1='" & StrToFinde & "';"
'هو إسم الجدول الاول Table1 حيث
'هو الحقل الذى ستتم عليه المقارنه Field1
'هو القيمه التى ستتم مقارنتها StrToFinde
Set RS1 = Db1.OpenRecordset(SQL)
Set RS2 = Db2.OpenRecordset("Table2")
'هو إسم الجدول الثانى Table2 حيث
With RS1
    While Not .EOF
    I = 0
        RS2.AddNew
        For Each FLD In .Fields
            RS2.Fields(I) = .FLD.Value
            I = I + 1
            DoEvents
        Next
    RS2.Update
    Wend
End With
RS1.Close
RS2.Close
Db1.Close
Db2.Close