با سلام
دو تا جدول متفاوت tbl1و tbl2 با فیلدهای مشترک داریم میخوائیم اطلاعات فیلدهای مشترک tbl1 رو بریزم تو tbl2 اونم یکبار و غیر تکراری حالا با استفاده از کدهای VBA یا SQL
با سلام
دو تا جدول متفاوت tbl1و tbl2 با فیلدهای مشترک داریم میخوائیم اطلاعات فیلدهای مشترک tbl1 رو بریزم تو tbl2 اونم یکبار و غیر تکراری حالا با استفاده از کدهای VBA یا SQL
سلام!نوشته شده توسط moustafa
وقت بخیر !
فکر می کنم سوال شما مشابه سوالی باشه که در این تاپیک پرسیده شده . نمونه اصلاح شده پست 3 تاپیک رو بررسی بفرما !
با عرض سلام و احترام جناب اقای بهرامی عزیز
عارضم که در برنامه فوق به فیلدها تک به تک اشاره شده و ما میدونیم که فیلدهای مشترک چی هست . در مورد من ممکنه جدول دوم دچار تغییرات بشه فیلد مشترک کمتر یا ساختارش عوض بشه اون موقع با کدهای شماها چون فیلد جدول اول در فیلد جدول دوم نیست الحاق صورت نمیگه وارور میده .مگر اینکه دستی فیلدی که حذف شده رو از کد حذف کنیم حالا اگه بالای ده تا جدول به این منظور داشته باشیم کار سخت و احتمال اشتباه زیاد و نیاز به زمان بیشتری است .
با تشکر
با سلام و احترام متقابل
در کدهای اصلاح شده نمونه ای که لینکشو در پست شماره 2 قرار داده ام ابتدا با استفاده از دوحلقه For Each فیلدهای دو جدول رو با هم مورد مقایسه قرار داده ام و در حلقه دوم این شرط رو بکار بردام که اگر نام فیلدهای جدول اول و دوم با هم برابر بودن نام فیلدهای مشترک رو پشت سرهم با استفاده از جداکننده , در متغییر رشته ای Fld1Name قرار بده . در واقع متغییر Fld1Name نام فیلدهای قسمت اول عبارت "INSERT INTO که در داخل پرانتز قرار میگیره برمیگردونه.
در همین قسمت شرط قسمت دوم عبارت "INSERT INTO بعد از پرانتز که با SELECT شروع و ترکیب نام جدول و فیلدها رو در متغییر رشته ای Fld1Select قرار داده ام و ترکیب این دو متغییر رو در متغییر رشته ای StrSql بکار برده ام و در نهایت با استفاده از دستور DoCmd.RunSQL مشخص کرده ام که کد اسکیول StrSql اجرا شود .
فعلا این کدها رو جایگزین کدهای نمونه لینک فوق کن ببین چه نتیجه ای حاصل میشه.
ان شاءالله به مرور با توجه به توضیحات بیشترتون و اینکه چه هدفی از انجام چنین کاری دارین کدها رو در صورت لزوم تغییر میدم تا نتیجه نهائی حاصل بشه.
Dim Fld1 As DAO.Field, Fld2 As DAO.Field
Dim Fld1Select As String
Dim StrSql As String
Dim Fld1Name As String
If DCount("*", "MainKala_tbl", "transferred=false") = 0 Then
MsgBox "رکورد جديدي براي انتقال وجود ندارد "
Exit Sub
End If
Dim RS1 As DAO.Recordset
Set RS1 = CurrentDb.OpenRecordset("MainKala_tbl")
Dim RS2 As DAO.Recordset
Set RS2 = CurrentDb.OpenRecordset("ChildKala_tbl")
For Each Fld1 In RS1.Fields
For Each Fld2 In RS2.Fields
If Fld2.Name = Fld1.Name Then
Fld1Name = Fld1Name & ", " & Fld1.Name
Fld1Select = Fld1Select & "," & "MainKala_tbl." & Fld1.Name
End If
Next
Next
Fld1Name = Right(Fld1Name, Len(Fld1Name) - 1)
Fld1Select = Right(Fld1Select, Len(Fld1Select) - 1)
DoCmd.SetWarnings False
StrSql = "INSERT INTO ChildKala_tbl (" & Fld1Name & ")SELECT " & Fld1Select & " FROM MainKala_tbl"
DoCmd.RunSQL "Update MainKala_tbl Set MainKala_tbl.transferred=true"
DoCmd.RunSQL StrSql
Me.ChildKala_sfrm.Requery
DoCmd.SetWarnings True
RS1.Close
RS2.Close
Set RS1 = Nothing
Set RS2 = Nothing
من ایندفعه کدهای بالا رو در یک تابع عمومی قرار دادم که بتونی نام جدول مبدا و مقصد رو انتخاب و در اون قرار بدی و با فراخوانی تابع عملیات انتقال رو انجام بدی
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
آخرین ویرایش به وسیله eb_1345 : شنبه 07 مهر 1403 در 10:00 صبح
سلام و روز خوش
راه حل تمیز و موثری هست.
در حلقه دوم و بعد ازFld1Select = Fld1Select & "," & SourceTable & "." & Fld1.Nameمیشه یک exit for اضافه کنین.
پیشنهاد میکنم یک تاپیک جدید آموزشی برای UPSERT بسازین،
به این صورت که اگر رکورد قبلا در destination وجود داره ولی در source آپدیت شده، اونطرف هم آپدیت بشه،
و اگر رکورد جدید در source هست اونطرف insert بشه.
و این که نیازی به فیلد transferred هم نباشه!
چون ممکنه که این امکان نباشه.
با سپاس فراوان جناب بهرامی فیلد درخواست رو از جدول فرعی پاک کردم متاسفانه اور مورد نظر رو داد
Untitled3.png
چشمام اینقدر خسته است که قادر به تشخیص تفاوت با کدهای قبلی یا سابروتین رو نداره اگه فانکشن وسابروتین یکسان باشه قطعا همون اورر رو میده
[QUOTE=eb_1345;2478177
ان شاءالله به مرور با توجه به توضیحات بیشترتون و اینکه چه هدفی از انجام چنین کاری دارین کدها رو در صورت لزوم تغییر میدم تا نتیجه نهائی حاصل بشه.
[CODE]
بانک اطلاعاتی برنامه مورد استفاده به نحوی از انحاء حالا ناشی ازقوانین و آئین نامه ها ، الگوریتم و روشها ، نیازمندیها و...دچار تغییر میشه .بانک خام و جدید باید جایگزین بانک قدیمی که حاوی اطلاعات است بشه .در حالت دستی جدولهای قدیمی رو امپورت میکنیم یا مستقیما و با کوئری الحاقی اطلاعات رو میریزم تو جداول جدید. بدیهیه که هر جا فیلدی در مقصد نباشه یا ساختارش همخونی نداشته باشه اور میده وکوئری اجرا نمیشه .یه فرم میخوائیم در برنامه قدیمی که اطلاعات جداول همنامشو بریزه در برنامه جدید که مسیرش از طریق دیالوگ فایل تعیین میشه.سایر آبجکتها هم در برنامه جدید مستقل از قدیمی است و در اخر برنامه قدیمی حذف وبرنامه جدید با اطلاعات بروزرسانی میشه
با تشکر
سلام
احسنت !
خدمت استاد خودم عرض کنم که ایجاد فیلد transferred در جدول مبدا در کاری که جناب moustafa در نظر دارن انجام بدهند موقتی و صرفاً برای عدم انتقال مجدد اطلاعات از جدول مبدا به جدول مقصد میباشه .
ایشون ظاهراً بانک اطلاعاتی برنامشون که شامل تعدادی جدول میباشه که الآن یک بانک اطلاعاتی جدید شامل همون جداول ولی با تغییراتی در ساختار فیلدهای جداول( اضافه یا کم شدن فیلد یا تغییر در دیتاتایپ ) ولی خالی از اطلاعات ایجاد کرده ان . حالا الان میخواهند با کد نویسی اطلاعات جدول های بانک اطلاعاتی قدیم در جدول های بانک اطلاعاتی جدید انتقال بدهند و چون بعد از انتقال اطلاعات ، بانک اطلاعاتی جدید جایگزین بانک اطلاعاتی قدیم میشه و فیلد transferred در بانک اطلاعاتی قدیم ایجاد شده از این بابت دیگه نیازی به حذف این فیلد از جداول نمی باشه.
پیشنهاد می کنم اگه تعداد جداول بانک اطلاعاتی ایشون زیاده و اضافه کردن فیلد transferred به همه اونها کار زمانبریه از کد زیر برای اضافه کردن این فیلد که از نوع چک باکسه به همه جداول از کد زیر استفاده کنن :
On Error Resume Next
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Set db = CurrentDb
For Each tdf In db.TableDefs
If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*") Then
DoCmd.RunSQL "ALTER TABLE " & tdf.Name & " ADD COLUMN Transferred BIT"
End If
Next
Set tdf = Nothing
Set db = Nothing
برای حذف کلی فیلد فوق از همه جدول ها هم کافیه در کد بالا بجای ADD COLUMN از Drop COLUMN استفاده کنن
آخرین ویرایش به وسیله eb_1345 : یک شنبه 08 مهر 1403 در 05:27 صبح
با سلام دوباره
من کدها رو برای انتقال اطلاعات کل جداول بانک قدیم رو به جداول بانک جدید تغییر دادم
در ضمیمه دو تا فایل اکسس یکی با نام 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
از دوست بزرگوارم جناب استاد مازولاق عزیز خواهش می کنم کدها رو بررسی بفرماین و اگه تشخیص میدن جاهائی از کدها باید اصلاح بشه یادآوری نمایند.
راستی فراموش نشه بر اساس تغییراتی که در کدهای پست قبل صورت گرفته انتقال اطلاعات به فیلدهای جدول فایل مقصد که از نظر نام و دیتا تایپ با فیلد جدول مبدا برابر باشه صورت میگیره و اگه فیلد جدول مقصد هم نام فیلد جدول مبدا باشه ولی دیتایپ اونها با هم یکی نباشه انتقالی در اون فیلد صورت نمی گیره
جناب بهرامی عزیز، ندیده فعلا بسیار سپاسگذارم از فعالیت دلسوزانه وبسیار خلاقانه که آدم لذت میبره و حض میکنه
سلام دوباره
یک فیلد اینچنینی که مشخص کنه رکورد از قبل append شده یک نیاز کاملا منطقی و بجا هست و اصولا راه درستش همینه،
و این کد پیوست هم که خودش به تک تک این فیلد رو به همه جدولها اضافه میکنه دیگه راه رو بر هر نوع بهانه ای میبنده.
من هدف دیگه ای دارم که ممکنه این تاپیک رو به بیراهه ببره،
حالا اگر فرصتی پیش آمد در یک تاپیک مستقل برای UPSERT این رو ادامه میدیم.
هرچند که آب سربالا نمیره، ولی چَشم.
این چک برای یکسان بودن نوع دیتا خیلی خوب و بجا بود:
ElseIf Fld2.Name = Fld1.Name And Fld2.Type <> Fld1.Type Then
'MsgBox " انتقال اطلاعات به فيلد فوق صورت نگرفت " & ...
Exit For
End If
شاید بد نباشه یک چک هم برای فیلدهای multivalue بذارین که پروسه کپی اونها متفاوت هست،
البته شما از sql insert استفاده کردین و احتمالا مشکلی پیش نمیاد (به شرطی که ساختار هر دو فیلد دقیقا یکی باشه)،
ولی کلا این فیلد multivalue شّر هست!
==============
به روال همیشگی کد تمیز و کارآمدی هست،
که با توضیح کافی همراه شده.
لازم هست بنوبه خودم از وقتی که میگذارین و زحمتی که قبول میکنین تشکر کنم.
سپاسگزارم استاد گرامی !
ممنون از دلگرمی های همیشگیتون
دست شما درد نکنه دقیقا همون چیزیه که میخواستم
در 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 رکوردست ها استفاده کردم
آخرین ویرایش به وسیله eb_1345 : دوشنبه 09 مهر 1403 در 01:17 صبح
البته از اونجایکه ممکنه بعد از انتقال اطلاعات به بانک اطلاعاتی جدید بعدا اطلاعات جدیدی به بانک اطلاعاتی قدیم اضافه شده باشه وبه همین خاطر دوباره با کلیک بر روی کمند باتن انتقال اقدام به انتقال مجدد بشه کل اطلاعات جدولی که اطلاعات جدید به اون اضافه شده به جدول هم نام در بانک اطلاعاتی جدید اضافه میشه به همین لحاظ بهتره قبل از انجام عملیات انتقال ، ابتدا اطلاعات جداول بانک اطلاعاتی جدید حذف بشه
از کد زیر جهت حذف اطلاعات جداول بانک اطلاعاتی جدید در حلقه اول For Each استفاده میشه:
NewDataBasePath = Access.CurrentProject.path & "\NewData.accdb"
For Each tdf In DBEngine.OpenDatabase(NewDataBasePath, False, False, "").TableDefs
If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*") Then
Set RS = DBEngine.OpenDatabase(NewDataBasePath, False, False, "").OpenRecordset(tdf.Name)
DoCmd.RunSQL "DELETE FROM [;DATABASE=" & NewDataBasePath & "]." & RS.Name & ""
End If
Next
بدیهیه که با ریست شدن اطلاعات جداول بانک اطلاعاتی جدید دیگه نیازی به کدهای زیر وجود نداره :
If RS2.Name = RS1.Name And RS1.RecordCount > 0 And RS2.RecordCount = RS1.RecordCount Then
MsgBox "! قبلا منتقل شده " & RS1.Name & " اطلاعات جدول ", vbOKOnly + vbInformation + vbMsgBoxRight, "!توجه"
End If
آخرین ویرایش به وسیله eb_1345 : سه شنبه 10 مهر 1403 در 07:32 صبح
و دقیقا شد همون چیزی که میخواستم کنترل شده بدون دخالت کاربر و پیغام عملیات مربوط به هر جدول. بسیار عالی و لذت بخش .
این اتفاق برا من نمی افته به محض بارگذاری اطلاعات نسخه قبلی غیر قابل دسترس میشه و حتما باید با نسخه جدید کار بشه مگه اینکه تا نهایی شدن نسخه جدید یا در صورت بروز مشکل در نسخه جدید بخوایم دوباره با برنامه قبلی کار کنیم که اینم در نوع خودش ایده خوبیه . با تشکر
بنظرتون میشه از این ایده گرفت برای اپدیت کلی برنامه با این الگوریتم
1-نسخه قدیمی بطور مخفی از طریق نسخه جدید باز میشه بمنظور کنترل و بررسی و اعتبار سنجی کلیه عملیات فایل log ساخته بشه
2-کدهای انتقال اطلاعات اجرامیشه
3-بمنظور عدم دسترسی به نسخه قدیمی تمامی پسوردهای کاربران حذف وپیغام بعلت ارتقا به نسخه بالاتر دسترسی ممکن نمی باشد صادرمیشه
4-برنامه قدیمی بسته میشه
5-کوئریها یا کدهای مربوط به فیلدهای جدید بمنظور آپدیت اطلاعات جدید یا دیفالت اجرا میشه
فایل لاگ ظاهر بشه برای بررسی درست عملیات و در آخر در صورت اوکی بودن :
6-یک نسخه از فرانت برنامه جدید در کامپیوتر کلاینتها کپی و به دیتابیس بک اند جدید لینک بشه
با تشکر
با سلام واحترام
از بذل توجه وحضور گرم وهمیشگی شما بزرگوار نیز سپاسگذارم
با سلام مجدد
بله ، همونطور که جنابعالی اشاره کردین وقتی ساختار هر دو فیلد در هر دو بانک یکی باشه مشکلی در انتقال اطلاعات پیش نمیاد
بنظر من برای فیلد multivalue چهار خصوصیت اصلی زیر وجود داره که با مقایسه این چهار خصوصیت در فیلدهای جداول هر دوبانک اطلاعاتی میتوان به مغایرت یا یکی بودن اونها پی برد
خصوصیت های اصلی فیلد multivalue
1- DisplayControl
2- RowSource
3- RowSourceType
4-AllowMultipleValues
فکر می کنم در حلقه کدهای پست های بالا بشه بصورت زیر این خصوصیات رو در هر دو رکورست مقایسه و نتیجه رو بررسی کرد:
ElseIf Fld2.Name = Fld1.Name And Fld2.Type = Fld1.Type And Fld2.Properties("DisplayControl").Value <> Fld1.Properties("DisplayControl").Value And Fld2.Properties("RowSource").Value <> Fld1.Properties("RowSource").Value And Fld2.Properties("RowSourceType").Value <> Fld1.Properties("RowSourceType").Value And
Fld2.Properties("AllowMultipleValues").Value <> Fld1.Properties("AllowMultipleValues").Value Then
آخرین ویرایش به وسیله eb_1345 : سه شنبه 10 مهر 1403 در 14:51 عصر
لینکی پست 2 تاپیک آپدیت برنامه اکسس ایجاد شده خودتون رو بررسی نکردین ؟
کدها رو بصورت زیر تغییر دادم ولی به نتیجه دلخواه نرسیدم
بقول استاد این فیلد multivalue فیلد شّر و شوریه
راستش فعلاً دیگه حوصله تغییرات جدید و تست کردن رو ندارم ، ان شاءالله بعدا سرفرصت و با حوصله سعی میشه بررسی بیشتری رو این کدها صورت بگیره که نتیجه دلخواه بدست بیاد . بالاخره ضرر نداره این تاپیک به یک نتیجه مطلوب و دلخواهی برسه
Dim NewDataBasePath As String
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 tblFinal As String
Dim fldFinal As String
Public Sub AppendCommonFieldsData()
'On Error Resume Next
On Error GoTo Err_Handler
NewDataBasePath = Access.CurrentProject.path & "\NewData.accdb"
If Dir(NewDataBasePath) = "" Then
MsgBox "! در مسير جاري موجود نمي باشد NewData.accdb بانک اطلاعاتي ", vbOKOnly + vbCritical + vbMsgBoxRight, "!خطا"
Exit Sub
End If
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(NewDataBasePath, False, False, "").OpenRecordset(tdf.Name)
DoCmd.SetWarnings False
If RS2.Name = RS1.Name And RS1.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
If Fld1.Type = 1 Or Fld1.Type = 4 Or Fld1.Type = 10 Then
tblFinal = RS1.Name
fldFinal = Fld1.Name
If Fld1.Properties("DisplayControl") <> acTextBox Then
If Fld2.Properties("DisplayControl") = Fld1.Properties("DisplayControl") And Fld2.Properties("RowSource") = Fld1.Properties("RowSource") And Fld2.Properties("RowSourceType") = Fld1.Properties("RowSourceType") And Fld2.Properties("AllowMultipleValues") = Fld1.Properties("AllowMultipleValues") Then
FldName = FldName & ", " & Fld1.Name
Fld1Select = Fld1Select & "," & tdf.Name & "." & Fld1.Name
End If
' Exit For
Else
FldName = FldName & ", " & Fld2.Name
Fld1Select = Fld1Select & "," & tdf.Name & "." & Fld2.Name
End If
ElseIf Fld1.Type <> 1 And Fld1.Type <> 4 And Fld1.Type <> 10 Then
FldName = FldName & ", " & Fld1.Name
Fld1Select = Fld1Select & "," & tdf.Name & "." & Fld1.Name
' Exit For
End If
ElseIf Fld2.Name = Fld1.Name And Fld2.Type <> Fld1.Type Then
Exit For
End If
Next
Next
FldName = Right(FldName, Len(FldName) - 1)
Fld1Select = Right(Fld1Select, Len(Fld1Select) - 1)
StrSql = "INSERT INTO [;DATABASE=" & NewDataBasePath & ";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
Exit_Handler:
Exit Sub
Err_Handler:
If err.Number = 3270 Then
MsgBox err.Number & ":" & tblFinal & "/" & fldFinal
Resume Next
ElseIf err.Number = 3824 Then
MsgBox err.Number & ":" & tblFinal & "/" & fldFinal
Resume Next
Else
'other error here
MsgBox err.Number & ": " & err.Description
Resume Exit_Handler
End If
RS1.Close
RS2.Close
Set RS1 = Nothing
Set RS2 = Nothing
Set tdf = Nothing
End Sub
Private Sub CmdDellDataFromNewTabels()
On Error Resume Next
NewDataBasePath = Access.CurrentProject.path & "\NewData.accdb"
For Each tdf In DBEngine.OpenDatabase(NewDataBasePath, False, False, "").TableDefs
If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*") Then
Set RS = DBEngine.OpenDatabase(NewDataBasePath, False, False, "").OpenRecordset(tdf.Name)
DoCmd.RunSQL "DELETE FROM [;DATABASE=" & NewDataBasePath & "]." & RS.Name & ""
End If
Next
End Sub
Private Sub Command5_Click()
Call CmdDellDataFromNewTabels
Call AppendCommonFieldsData
End Sub
من در جدولهای خود که شامل فیلد مولتی ولیو هست امتحان کردم علیرغم اینکه پیام میده منتقل شد متاسفانه اطلاعات الحاق نمیشه!!! ولی چرا در حالت دستی انتقال صورت میگیره؟!
این که میگم فیلد multivalue شرّ مطلق هست برای همین چیزهاست!
در واقع این فیلد برای استفاده در فرم هست و برای نگهداری دیتا مطلقا مناسب نیست،
نه میتونین به راحتی update و insert کنین و نه به هیچ دیتابیسی میشه اکسپورت کرد.
شما نمیتونین کوئری update/insert/delete رو اینا انجام بدین،
چون خودش یک رکوردست (یعنی یک جدول) هست و نه یک مقدار ساده،
برای همین روش جناب بهرامی (که خیلی تمیز و سرراست و بطور منطقی مبتنی بر کوئری هست)
اینجا کار نمیکنه و باید با VBA کار کنین.
برای این که تاپیک طولانی شده در یک تاپیک جدا توضیح میدم.
سلام و عرض ادب و تشکر .
بله ومتاسفانه من کلی جدول با فیلدهای مولتی ولیو دارم که قراره کوچ کنیم به اس کیو ال سرور و اینجاست که باید دوباره از اول شروع کنیم به طراحی جدولها و کدنویسی اتصال به اس کیو ال . همچی از نو فقط الگوریتم و تحلیل و نقشه راه مشخصه .نمیدونم کیا میگن ولی میگن نون پنیر با دل دردش از چلوکباب گرونتر درمیاد
سلام دوباره
آره، این از اون چیزایی هست که بعدا سداش درمیاد!
آموزش: کپی فیلد multi-valued به جدول دیگر (barnamenevis.org)
با تشکر .
من یه ایده دیگه بنظرم رسید چون ورود اطلاعات از طریق فرم با همچین مشکلی مواجه نمیشه . فرم ورود اطلاعات هر یک از جدولها بطور مخفی باز و رکوردستی از جدول قدیمی تشکیل و اطلاعات هر فیلد متناظر به اون طی یه حلقه for و MoveNext برای recordset و save و go to record ,..addnew برای form وارد بشه اینطور فیلدهای جدید هم با توجه به مقدار دیفالت و یا شروط مربوط مقدار دهی میشه
قوانین ایجاد تاپیک در تالار
پاسخ با نقل قول