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

[eb_1345]

من ایندفعه کدهای بالا رو در یک تابع عمومی قرار دادم که بتونی نام جدول مبدا و مقصد رو انتخاب و در اون قرار بدی و با فراخوانی تابع عملیات انتقال رو انجام بدی

Public Sub AppendCommonFieldsData(SourceTable As String, TargetTable As String, FieldName As String)

'On Error Resume Next

Dim Fld1 As DAO.Field, Fld2 As DAO.Field, StrSql As String, FldName As String, Fld1Select As String

If DCount("*", "" & SourceTable & "", "" & FieldName & " = False") = 0 Then

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

   Exit Sub

End If

Dim RS1 As DAO.Recordset

Set RS1 = CurrentDb.OpenRecordset(SourceTable)

Dim RS2 As DAO.Recordset

Set RS2 = CurrentDb.OpenRecordset(TargetTable)

For Each Fld1 In RS1.Fields

    For Each Fld2 In RS2.Fields

        If Fld2.Name = Fld1.Name Then

           FldName = FldName & ", " & Fld1.Name

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

        End If

    Next

Next

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

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

DoCmd.SetWarnings False

StrSql = "INSERT INTO " & TargetTable & " (" & FldName & ")SELECT " & Fld1Select & " FROM " & SourceTable & " Where (" & SourceTable & "." & FieldName & "=false)"

DoCmd.RunSQL StrSql

DoCmd.RunSQL "Update " & SourceTable & " Set " & SourceTable & "." & FieldName & "=true Where " & SourceTable & "." & FieldName & "=false"

DoCmd.SetWarnings True

RS1.Close

RS2.Close

Set RS1 = Nothing

Set RS2 = Nothing

End Sub