append کردن اطلاعات فیلدهای مشترک دو جدول متفاوت با کد

[eb_1345]

بانک اطلاعاتی برنامه مورد استفاده به نحوی از انحاء حالا ناشی ازقوانین و آئین نامه ها ، الگوریتم و روشها ، نیازمندیها و...دچار تغییر میشه .بانک خام و جدید باید جایگزین بانک قدیمی که حاوی اطلاعات است بشه .در حالت دستی جدولهای قدیمی رو امپورت میکنیم یا مستقیما و با کوئری الحاقی اطلاعات رو میریزم تو جداول جدید. بدیهیه که هر جا فیلدی در مقصد نباشه یا ساختارش همخونی نداشته باشه اور میده وکوئری اجرا نمیشه .یه فرم میخوائیم در برنامه قدیمی که اطلاعات جداول همنامشو بریزه در برنامه جدید که مسیرش از طریق دیالوگ فایل تعیین میشه.سایر آبجکتها هم در برنامه جدید مستقل از قدیمی است و در اخر برنامه قدیمی حذف وبرنامه جدید با اطلاعات بروزرسانی میشه
با تشکر

با سلام دوباره
من کدها رو برای انتقال اطلاعات کل جداول بانک قدیم رو به جداول بانک جدید تغییر دادم
در ضمیمه دو تا فایل اکسس یکی با نام OldData.accdb که مربوط به بانک اطلاعاتی قدیم است و دیگری با نام accdbNew.Data که مربوط به بانک اطلاعاتی جدید است .جداول بانک اطلاعاتی جدید همون جداول بانک اطلاعاتی قدیم است با این تفاوت که بعضی از فیلدهای اونها آن نسبت به جداول بانک اطلاعاتی قدیم
از نظر تعداد فیلد یا دیتا تایپ با هم فرق می کنه
کدهای انتقال اطلاعات در فرم بانک قدیم است .

Public Sub AppendCommonFieldsData()

'On Error Resume Next

Dim Fld1 As dao.Field, Fld2 As dao.Field, StrSql As String, FldName As String, Fld1Select As String, tdf As dao.TableDef

Dim RS1 As dao.Recordset

Dim RS2 As dao.Recordset

Dim NewDataBsePath As String

NewDataBsePath = "e:\NewData.accdb"

For Each tdf In CurrentDb.TableDefs

    If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*") Then

       Set RS1 = CurrentDb.OpenRecordset(tdf.Name)

       Set RS2 = DBEngine.OpenDatabase(NewDataBsePath, False, False, "").OpenRecordset(tdf.Name)

       If DCount("*", "" & RS1.Name & "", "Transferred=0") = 0 Then

          MsgBox "رکورد جديدي براي انتقال وجود ندارد "

          Exit Sub

       End If

       If RS2.Name = RS1.Name Then

          For Each Fld1 In RS1.Fields

              For Each Fld2 In RS2.Fields

                  If Fld2.Name = Fld1.Name And Fld2.Type = Fld1.Type Then

                     FldName = FldName & ", " & Fld1.Name

                     Fld1Select = Fld1Select & "," & tdf.Name & "." & Fld1.Name

                     Exit For

                  ElseIf Fld2.Name = Fld1.Name And Fld2.Type <> Fld1.Type Then

                     'MsgBox " انتقال اطلاعات به فيلد فوق صورت نگرفت " & Fld2.Name & " بعلت مغايرت نوع ديتاتايپ فيلد ", vbOKOnly + vbInformation + vbMsgBoxRight, "!توجه"

                     Exit For

                  End If

               Next

          Next

          FldName = Right(FldName, Len(FldName) - 1)

          Fld1Select = Right(Fld1Select, Len(Fld1Select) - 1)

          DoCmd.SetWarnings False

          StrSql = "INSERT INTO [;DATABASE=" & NewDataBsePath & ";PWD=""]." & tdf.Name & " (" & FldName & ")SELECT " & Fld1Select & " FROM " & tdf.Name & " Where (" & tdf.Name & ".Transferred=false)"

          DoCmd.RunSQL StrSql

          DoCmd.RunSQL "Update " & tdf.Name & " Set " & tdf.Name & ".Transferred=TRUE Where " & tdf.Name & ".Transferred=false"

          DoCmd.SetWarnings True

          FldName = ""

          Fld1Select = ""

       End If

    End If

Next

RS1.Close

RS2.Close

Set RS1 = Nothing

Set RS2 = Nothing

Set tdf = Nothing

End Sub

از دوست بزرگوارم جناب استاد مازولاق عزیز خواهش می کنم کدها رو بررسی بفرماین و اگه تشخیص میدن جاهائی از کدها باید اصلاح بشه یادآوری نمایند.