طلب تعديل كود الاستعلام VBA

[qathi]

السلام عليكم  اساتذتنا الاكارم واخواني أعضاء المنتدى الرائع

أسأل الله أن تكونوا جميعاً في أتم الصحة والعافية

طلب تعديل كود الاستعلام VBA

---------------

عمل الكود:
 الكود يقوم بالتالي يقوم الحاق حقول من استعلام ItemsCopy_Qr الى جدول BarcodeItems_T مع تكرار السجلات حسب رقم حقل QuantityS الموجود في الاستعلام الاول ItemsCopy_Qr في كل سجل

المطلوب:
تعديل كود الاستعلام  بحيث لا يقوم بالحاق وتكرار السجلات ألا بشرطين هما :

1- الشرط الاول : السجلات التي تحتوي رقم الحقل InvoiceNum في استعلام ItemsCopy_Qr يساوي نفس الموجود في حقل القائمة المنسدلة K1 بالنموذج Run_F  كالكود التالي:
WHERE (((ItemsCopy_Qr.InvoiceNum)=[Forms]![Run_F]![K1]))

2- الشرط الثاني : السجلات الذي يكون حقل sisl مؤشر علية الصح , كالكود التالي:
 ((ItemsCopy_Qr.sisl)=1)
أو
 ((ItemsCopy_Qr.sisl)=True)

---------------

'On Error Resume Next
Const RTableName As String = "ItemsCopy_Qr"
Const ALLItemsTableName As String = "BarcodeItems_T"
Dim stmailList As String
Dim MyDB As Database
Dim r As Recordset
Set MyDB = CurrentDb
Dim SqlSt As String
Dim ItemCounter, RRecordCounter, count As Integer
Set r = MyDB.OpenRecordset(RTableName)
r.MoveFirst
Do
r.MoveNext
Loop Until r.EOF
DoCmd.SetWarnings False
SqlSt = " DELETE " & ALLItemsTableName & ".* FROM " & ALLItemsTableName & " ; "
DoCmd.RunSQL (SqlSt)
For RRecordCounter = 1 To r.RecordCount
r.MoveFirst
r.Move RRecordCounter - 1
For ItemCounter = 1 To r.Fields("QuantityS") 


SqlSt = "INSERT INTO " & ALLItemsTableName & " (BarCodeNumber,PriceS,ItemName,curName,CuCodn,CodeCounter) VALUES ( """ & r.Fields("BarcodeReader") & """,""" & r.Fields("PriceS") & """,""" & r.Fields("ItemName") & """,""" & r.Fields("currNames") & """,""" & r.Fields("CuCode") & """," & ItemCounter & " );"


DoCmd.RunSQL (SqlSt)
Next ItemCounter
Next RRecordCounter
DoCmd.SetWarnings True
r.Close
Set r = Nothing
Set MyDB = Nothing

---------------
شاكرا لكم على ماتقدموه من جهد ووقت لنا .. فجزاكم الله عنا خيرا

ملاحظة/
- تنفيذ الامر من خلال زر في نموذج Run
- الكود موجود في موديول BarcodePrintGroup_M
- يتم فك ضغط الملف المرفق في القرص D

mm.rar

تم تعديل سبتمبر 24, 2022 بواسطه qathi

[qathi]

اين اساتذتنا الافاضل ولا أرى رداً لهم

[ابوبسمله]

وعليكم السلام ورحمه الله وبركاته

اتفضل اخى @qathi

تم التعديل ان شاء الله يكون ما تريد

Set r = MyDB.OpenRecordset("SELECT InvoiceTT.InvoiceNum, InvoiceTT.ItemId, ItemsT.ItemName, ItemsT.BarcodeReader, InvoiceTT.priceu, ItemsT.PriceS, InvoiceTT.QuantityS, InvoiceTT.sisl, tbl_curr.currNames, tbl_curr.CuCode " & _
"FROM (ItemsT INNER JOIN InvoiceTT ON ItemsT.[ItemID] = InvoiceTT.[ItemId]) LEFT JOIN tbl_curr ON InvoiceTT.CuryID = tbl_curr.currID " & _
"WHERE (((InvoiceTT.InvoiceNum)='" & [Forms]![Run]![K1] & "') AND ((InvoiceTT.sisl)=True));")

بالتوفيق

 

mm.rar

تم تعديل سبتمبر 24, 2022 بواسطه احمد الفلاحجي

[qathi]

16 ساعات مضت, احمد الفلاحجي said:

تم التعديل ان شاء الله يكون ما تريد

 

قمت بتجربة الملف بشكل بشكل سريع

 

أخي أحمد @احمد الفلاحجي ,, ماذا عساي أن أقول لك ؟  سوى أن أدعوا لك

(( أسأل الله أن يبشرك ويبشر والديك وذريتك بالجنة الفردوس الأعلى ,, وأن يرزقك السعادة الذي ترجوها من الله يوم أن تلقاه .. وأن يسعدك في الدنياء والأخرة )) .. كما أسعدتني

 

بارك الله فيك .. وشكرا على مجهودك الرائع

[ابوبسمله]

في 25‏/9‏/2022 at 17:03, qathi said:

ماذا عساي أن أقول لك ؟  سوى أن أدعوا لك

وهذا ما اريده

في 25‏/9‏/2022 at 17:03, qathi said:

(( أسأل الله أن يبشرك ويبشر والديك وذريتك بالجنة الفردوس الأعلى ,, وأن يرزقك السعادة الذي ترجوها من الله يوم أن تلقاه .. وأن يسعدك في الدنياء والأخرة )) .. كما أسعدتني

جزاك الله خيرا على طيب دعائك ولك مثله وزياده وربنا يسعد ايامك

في 25‏/9‏/2022 at 17:03, qathi said:

بارك الله فيك .. وشكرا على مجهودك الرائع

وفيك بارك الله اخى والشكر لله ثم لاخواننا واساتذتنا جزاهم الله عنا كل خير

اتفضل تعديل بسيط باستخدام الشرط داخل داله اللوب لانى لما عدلت كان الوقت متاخر فعدلت التعديل على السريع

Sub Create_Record_For_Every_Item3()

' تكرار السجلات لقاعدة البيانات المقسمة

Const RTableName As String = "ItemsCopy_Qr" ' الاستعلام الذي يتم الحاق منه السجلات
Const ALLItemsTableName As String = "BarcodeItems_T"   ' الجدول الذي الية يتم نسخ السجلات وتكرارها
Dim stmailList As String
Dim MyDB As Database
Dim r As Recordset
Dim SqlSt As String

Dim ItemCounter As Integer

Set MyDB = CurrentDb
Set r = MyDB.OpenRecordset(RTableName)

DoCmd.SetWarnings False

    SqlSt = " DELETE " & ALLItemsTableName & ".* FROM " & ALLItemsTableName & " ; "
    DoCmd.RunSQL (SqlSt)

Do
    If r.Fields("InvoiceNum") = [Forms]![Run]![K1] And r.Fields("sisl") = True Then
    
        For ItemCounter = 1 To r.Fields("QuantityS") ' تكرار السجلات حسب الرقم الذي يوجد في الحقل QuantityS
            
            SqlSt = "INSERT INTO " & ALLItemsTableName & " (BarCodeNumber,PriceS,ItemName,curName,CuCodn,CodeCounter) VALUES ( """ & r.Fields("BarcodeReader") & """,""" & r.Fields("PriceS") & """,""" & r.Fields("ItemName") & """,""" & r.Fields("currNames") & """,""" & r.Fields("CuCode") & """," & ItemCounter & " );"
            DoCmd.RunSQL (SqlSt)
            
        Next ItemCounter
        
    End If
    
    r.MoveNext
Loop Until r.EOF

DoCmd.SetWarnings True

    If ItemCounter > 0 Then
        MsgBox "تم ترحيل السجلات بنجاح"
    Else
        MsgBox "لا يوجد سجلات لترحيلها"
    End If
    
r.Close
Set r = Nothing
Set MyDB = Nothing
End Sub

مرفق الملف به ملفان واجه كل واحد بتعديل

بالتوفيق

mm.rar

[qathi]

في 29‏/9‏/2022 at 19:33, احمد الفلاحجي said:

مرفق الملف به ملفان واجه كل واحد بتعديل

بالتوفيق

mm.rar 141.68 kB · 12 downloads

 

السلام عليكم أخي أحمد @احمد الفلاحجي ,, اعذرني على تأخر ردي لأنشغالي .. ولأستوجاب عليا الرد لهاذا العمل الكبير والجميل

 

الله الله والابداع .. هنا اقف لك احتراما وتقديرا لهاذا الابداع ولعملك طريقتين لعمل نفس المطلوب في الملف الأخير .. من دون الاولى .. هنا نراء الاحتراف واللعب بالأكواد ..

ما شاء الله أخي الغالي

أخي أحمد عندما تصفحت الملفين كنت مندهشاً ولساني تلقائياً يدعوا لك في ضهر الغيب ولوالديك ولذريتك

لا يحضرني الان الوصف لمشاعري بالسعادة والفرحة الغامرة عند تصفحي الملفين 

لكن أسأل الله أن يجازيك عني خيرا الجزاء .. وبارك الله على ما قدمته لي من وقتك الثمين والجهد المذهل الذي يدل على احترافك وابداعك

فلك مني كل الشكر والتقدير

 

[ابوبسمله]

وعليكم السلام ورحمه الله وبركاته

جزاك الله خيرا اخى @qathi على دعائك ولك مثله وزياده

59 دقائق مضت, qathi said:

الذي يدل على احترافك وابداعك

وما انا الا طالب علم احبو عالطريق لاتعلم معكم وجزاهم الله خيرا اخواننا واساتذتنا الذين نتعلم منهم

ربنا يوفقك

[الحلبي]

11 ساعات مضت, احمد الفلاحجي said:

وما انا الا طالب علم احبو عالطريق لاتعلم معكم وجزاهم الله خيرا اخواننا واساتذتنا الذين نتعلم منهم

الاستاذ @qathi

هذا تواضع كبير من خبير كبير فى عالم اكسس لا يخفى عليه شئ فى اكسس

حتى العلماء فى شتى المجالات ما هم الا طالبو علم ـ احمد الفلاحجى خبير بمعنى الكلمة وما تحتويه 

وعن نفسى اقف له اختراما واجلال لما علمنى فى علم الاكسس

اللهم بارك فيه وبارك فى اسرته ووالدته ـ واجعله فى ميزان حسناته

[qathi]

6 ساعات مضت, الحلبي said:

هذا تواضع كبير من خبير كبير فى عالم اكسس لا يخفى عليه شئ فى اكسس

حتى العلماء فى شتى المجالات ما هم الا طالبو علم ـ احمد الفلاحجى خبير بمعنى الكلمة وما تحتويه 

وعن نفسى اقف له اختراما واجلال لما علمنى فى علم الاكسس

اللهم بارك فيه وبارك فى اسرته ووالدته ـ واجعله فى ميزان حسناته

أهلا أخي @الحلبي اشتقنا لك .. اشكرك على مرورك الطيب

 

صدقت في كل كلمة قلتها .. وتواضع أخي أحمد @احمد الفلاحجي يزيده احتراما وتقديرا في قلوبنا

[ابوبسمله]

14 ساعات مضت, الحلبي said:

هذا تواضع كبير من خبير كبير فى عالم اكسس لا يخفى عليه شئ فى اكسس

حتى العلماء فى شتى المجالات ما هم الا طالبو علم ـ احمد الفلاحجى خبير بمعنى الكلمة وما تحتويه 

وعن نفسى اقف له اختراما واجلال لما علمنى فى علم الاكسس

اللهم بارك فيه وبارك فى اسرته ووالدته ـ واجعله فى ميزان حسناته

جزاك الله خيرا دكتورنا العزيز ابوشادى ع كلماتك اللطيفه ودعواتك الطيبه اللهم تقبل ولكن انت تعلم ابو شادى باننى فعليا مازلت اتعلم ومن اسئلتكم اتعلم الكثير والكثير ومازال يخفى علي الكثير لاتعلمه وكل بشى بالصبر بيهون

وان شاء الله اكون عند حسن ظنكم بى تقبل تحياتى واحترامى

7 ساعات مضت, qathi said:

في قلوبنا

تسلم قلوبكم البيضاء وتقبل الله منكم دعواتكم واسال الله لكم وللجميع بالتوفيق والسداد

تقبلوا تحياتى اخوكم وابنكم الصغير احمد