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

[eb_1345]

در vba مشابه continuo در زبانهای مثل پایتون وجاوا و... نداریم که در حلقه های شمارشی نظیر for از یک شماره یا عضو با شرایطی که تعیین می کنیم بگذره در کد زیر با اولین شرط کلا از حلقه خارج میشه در حالیکه ما میخوائیم رد شه بره سراغ شی بعدی

For Each tdf In CurrentDb.TableDefs

   ' If DCount("*", "" & tdf.Name & "", "Transferred=false") = 0 Then

    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 RS1.Name & "رکورد جديدي براي انتقال وجود ندارد "

          Exit For

       End If

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 RS2.Name = RS1.Name And RS1.RecordCount > 0 And RS2.RecordCount = RS1.RecordCount Then

          MsgBox "! قبلا منتقل شده " & RS1.Name & " اطلاعات جدول ", vbOKOnly + vbInformation + vbMsgBoxRight, "!توجه"

       End If

       If RS2.Name = RS1.Name And RS1.RecordCount > 0 And RS2.RecordCount = 0 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 & ""

          DoCmd.RunSQL StrSql

          DoCmd.SetWarnings True

          FldName = ""

          Fld1Select = ""

          MsgBox "! منتقل شد " & RS1.Name & " اطلاعات جدول ", vbOKOnly + vbInformation + vbMsgBoxRight, "!توجه"

       End If

       If RS2.Name <> RS1.Name Then

          MsgBox "! در بانک اطلاعاتي جديد موجود نمي باشد " & RS1.Name & " جدول ", vbOKOnly + vbInformation + vbMsgBoxRight, "!توجه"

       End If

    End If

Next

RS1.Close

RS2.Close

Set RS1 = Nothing

Set RS2 = Nothing

Set tdf = Nothing

End Sub

کد های بالارو جایگزین کدهای قبلی کن ونتیجه رو بررسی کن !
در کدهای جدید فیلد Transferred که برای کنترل انتقال اطلاعات به جداول بانک قدیم اضافه کرده بودم حذف کردم و برای کنترل انتقال اطلاعات از مقایسه خصوصیت RecordCount رکوردست ها استفاده کردم