ناقل

بالنسبة للعربية انظر الصورة لتعديل اسماء التسمية التوضيحية للحقول بالنسبة للعدالة طبعا تقريبية اضف الحقل SupervisionCount في الجدول Teachers نمواصفت ( رقم - القيمة الافتراضية 0 ) ثم استخدم الكود التالي في زر التوزيع Dim db As DAO.Database Dim rsA As DAO.Recordset, rsB As DAO.Recordset Dim rsRooms As DAO.Recordset, rsDays As DAO.Recordset, rsTarget As DAO.Recordset Dim supervisionDate As Date, roomName As String Set db = CurrentDb() ' ? تمهيد: مسح الجدول وتصفير العدادات db.Execute "UPDATE Teachers SET SupervisionCount = 0" db.Execute "DELETE FROM TeacherAssignment" Set rsDays = db.OpenRecordset("SELECT * FROM SupervisionDays ORDER BY SupervisionDate", dbOpenDynaset) Set rsRooms = db.OpenRecordset("SELECT * FROM ExamRooms ORDER BY RoomName", dbOpenDynaset) Set rsTarget = db.OpenRecordset("TeacherAssignment") ' ? تحقق من توفر عدد كافٍ من المعلمين Dim totalSupervisionsNeeded As Long Dim availableA As Long, availableB As Long totalSupervisionsNeeded = DCount("*", "SupervisionDays") * DCount("*", "ExamRooms") availableA = DCount("*", "Teachers", "TeacherCategory = 'A' AND (ExamDate Is Null OR ExamDate Not In (SELECT SupervisionDate FROM SupervisionDays)) AND (CorrectionCommittee Is Null OR CorrectionCommittee = '')") availableB = DCount("*", "Teachers", "TeacherCategory = 'B' AND (ExamDate Is Null OR ExamDate Not In (SELECT SupervisionDate FROM SupervisionDays)) AND (CorrectionCommittee Is Null OR CorrectionCommittee = '')") If availableA < totalSupervisionsNeeded Or availableB < totalSupervisionsNeeded Then Dim response As VbMsgBoxResult response = MsgBox("عدد المعلمين المتاحين قد لا يكون كافياً لتغطية جميع القاعات في جميع الأيام." & vbCrLf & _ "هل ترغب في المتابعة مع ذلك؟", vbYesNo + vbQuestion, "تأكيد التوزيع") If response = vbNo Then MsgBox "تم إلغاء عملية التوزيع بناءً على طلب المستخدم.", vbInformation Exit Sub End If End If ' ?? بدء التوزيع Dim usedA As Collection: Set usedA = New Collection Dim usedB As Collection: Set usedB = New Collection Do While Not rsDays.EOF supervisionDate = rsDays!supervisionDate rsRooms.MoveFirst Do While Not rsRooms.EOF roomName = rsRooms!roomName ' معلم فئة A Set rsA = db.OpenRecordset("SELECT * FROM Teachers WHERE TeacherCategory='A' AND (CorrectionCommittee Is Null OR CorrectionCommittee='') ORDER BY SupervisionCount ASC", dbOpenSnapshot) rsA.MoveFirst Do While Not rsA.EOF If Not InCollection(usedA, rsA!TeacherName & "#" & supervisionDate) And (IsNull(rsA!ExamDate) Or rsA!ExamDate <> supervisionDate) Then rsTarget.AddNew rsTarget!TeacherName = rsA!TeacherName rsTarget!TeacherCategory = rsA!TeacherCategory rsTarget!ExamRoom = roomName rsTarget!supervisionDate = supervisionDate rsTarget.Update On Error Resume Next usedA.Add rsA!TeacherName, rsA!TeacherName & "#" & supervisionDate Err.Clear: On Error GoTo 0 db.Execute "UPDATE Teachers SET SupervisionCount = SupervisionCount + 1 WHERE TeacherName = '" & rsA!TeacherName & "'" Exit Do End If rsA.MoveNext Loop ' معلم فئة B Set rsB = db.OpenRecordset("SELECT * FROM Teachers WHERE TeacherCategory='B' AND (CorrectionCommittee Is Null OR CorrectionCommittee='') ORDER BY SupervisionCount ASC", dbOpenSnapshot) rsB.MoveFirst Do While Not rsB.EOF If Not InCollection(usedB, rsB!TeacherName & "#" & supervisionDate) And (IsNull(rsB!ExamDate) Or rsB!ExamDate <> supervisionDate) Then rsTarget.AddNew rsTarget!TeacherName = rsB!TeacherName rsTarget!TeacherCategory = rsB!TeacherCategory rsTarget!ExamRoom = roomName rsTarget!supervisionDate = supervisionDate rsTarget.Update On Error Resume Next usedB.Add rsB!TeacherName, rsB!TeacherName & "#" & supervisionDate Err.Clear: On Error GoTo 0 db.Execute "UPDATE Teachers SET SupervisionCount = SupervisionCount + 1 WHERE TeacherName = '" & rsB!TeacherName & "'" Exit Do End If rsB.MoveNext Loop rsRooms.MoveNext Loop rsDays.MoveNext Loop rsTarget.Close: rsA.Close: rsB.Close: rsRooms.Close: rsDays.Close Set rsTarget = Nothing: Set rsA = Nothing: Set rsB = Nothing Set rsRooms = Nothing: Set rsDays = Nothing: Set db = Nothing MsgBox "تم توزيع المعلمين بعد تحقق العدالة وشروط الاستبعاد!"

بالنسبة لاسماء الاعمدة . نعم ممكن تعديلها الى العربية .. سوف اشرح لك حال توفر جهاز حاسب لاني اكتب من الجوال ما المقصود بالعدالة؟ أن يحصل كل معلم على عدد أيام مراقبة متقارب قدر الإمكان. ألا يُكرر معلم في أكثر من يوم قبل استخدام باقي المعلمين. أن يُوزع العبء بالتساوي بين الفئتين A و B.

هذه الشروط موجودة في الجدول المعلمين ... دقق في الصورة المرفقة في علي احمد و منى عادل جرب لاسماء من عندك ووزع ودقق في النتيجة

ملاحظة القاعدة المرفقة لديك لم يتم التحميل ...... عملت لك قاعدة وفيها بيانات راجع جدول التوزيع هل تم بالشكل المطلوب ام لا ............... NA_1.accdb

اين بدايتك انت ... جداولك .... حتى نرى ما المطلوب ... ابدأ وسوف تجد الاجابات من مرتادي المنتدى ... ابشر

اين قاعدة بياناتك للتعديل عليها

اقرأ هذا الموضوع

هل الصور باسم رقم جلوس الطالب ام بأسماء اخرى

راجع هذا الموضوع

اخي @طاهر اوفيسنا ممكن اخر مثال تمت عليه التعديلات ... وماهو المطلوب بالضبط للعمل عليه

في حدث Before Update أو After Update الخاص بالحقل ضع هذا السطر Me.FADD = LTrim(Me.FADD)

استخدم هذه الطريقة

راجع قاعدة IF في الكود لأنها محددة بشرط أن يكون تاريخ الان أما شهر 3 أو 7

وعليكم السلام ورحمة الله وبركاته عن نفسي ... حاولت افهم آلية عمل برنامجك وعجزت فعل ذلك ... لانه من الصعب وضع اكواد وانت لم تفهم الآلية ... هل عند الاقتطاع يتم ادراج سجل جديد ام يتم تحديث نفس السجلات وايضا دفع الانخراط ... ماذا تريد انت من الكود أن يفعل ،???? لذلك توقفت عن الإجابة ...

جميل جدا ..... بارك الله فيك ... ماشاء الله تبارك الله دائما مبدع .... انا الحقيقة انشغل في برنامج خاص بي .. لكنك سبقت واجدت المطلوب

ارنا محاولاتك ... وبعدها نحاول معك

جرب .............. Private Sub cmd_Pay_installments_Click() On Error GoTo err_cmd_Pay_installments_Click ' .......................... الشطر الاول اقتطاع القروض Dim rst As DAO.Recordset 'Cridi and Elec Payments Set rst = CurrentDb.OpenRecordset("Select * From tbl_Loans Where [Payment_Month]=CDATE('" & Me.txtMonth & "')") rst.MoveLast: rst.MoveFirst Rc = rst.RecordCount a1 = 0 'just a flag a2 = 0 'just a flag If Rc = 0 Then MsgBox " لا توجد إقتطاعات لشهر " & Format(Me.txtMonth, "mmmm") & " " & Year(Me.txtMonth), vbInformation Exit Sub End If If Len(rst!Payment_Made & "") = 0 And Not IsNull(rst!Loan_Made) Then Select Case MsgBox("هل تريد أن يتم توزيع الإقتطاعات لشهر " & Me.txtMonth, vbYesNo + vbQuestion + vbDefaultButton1) Case vbYes For i = 1 To Rc rst.Edit If rst!Nr >= 6 Then rst!Payment_Made = 0# Else If rst!Loan_Type = "Cridi" Then rst!Payment_Made = rst!Loan_Made rst!sadad = rst!Loan_Made rst!Loan_Remise = 0 End If If rst!Loan_Type = "Elec" Then rst!Payment_Made = rst!Loan_Made rst!sadad = rst!Loan_Made rst!Loan_Remise = 0 End If End If If rst!sadad.Value = True Then rst!wada3 = "تم التسديد" Else rst!wada3 = "لم يتم التسديد" End If TheSum = TheSum + Nz(rst!Payment_Made, 0) rst.Update rst.MoveNext Next i ' .......................... الشطر الثاني اقتطاع الانخراط 'Other loans for March (3) and July (7) If Month(Now()) = 3 Or Month(Now()) = 7 Then Dim rstE As DAO.Recordset Set rst = CurrentDb.OpenRecordset("Select * From tbl_Loans") myCriteria = "([detach]='موظف'" myCriteria = myCriteria & " Or [detach]='عامل متعاقد توقيت كامل'" myCriteria = myCriteria & " Or [detach]='عامل متعاقد توقيت جزئي'" myCriteria = myCriteria & " Or [detach]='حارس متعاقد توقيت جزئي'" myCriteria = myCriteria & " Or [detach]='عون نظافه وتطهير')" Set rstE = CurrentDb.OpenRecordset("Select * From Employee Where " & myCriteria) rstE.MoveLast: rstE.MoveFirst Rc = rstE.RecordCount For i = 1 To Rc ' استثناء الموظف الذي دفع 3000 If Nz(DLookup("Payment_Made", "tbl_Loans", "EmployeeID=" & rstE!EmployeeID & " And [Payment_Made]=3000 And [Payment_Month]=#" & Me.txtMonth & "#"), 0) <> 3000 Then rst.FindFirst "[Loan_Type]='Inkhirat' And [EmployeeID]=" & rstE!EmployeeID & " And [Payment_Month]=#" & Me.txtMonth & "#" If rst.NoMatch Then rst.AddNew a2 = 1 rst!EmployeeID = rstE!EmployeeID rst!Loan_ID = 0 rst!Payment_Month = DateSerial(Year(Me.txtMonth), Month(Me.txtMonth), 1) rst!Payment_Made = DLookup("Other_Value", "TblOther", "ID=1") rst!Loan_Type = "Inkhirat" rst!Nr = GetNumDetach(rst!EmployeeID) rst!Remarks = "إقتطاع من الراتب لإنخراط شهر " & Year(Me.txtMonth) & "/" & Month(Me.txtMonth) rst!annee = Year(Date) If rst!Loan_Type = "Inkhirat" Then rst!sadad = rst!Payment_Made If rst!sadad.Value = True Then rst!wada3 = "تم الإنخراط" Else rst!wada3 = "لم يتم الإنخراط" End If End If TheSum = TheSum + Nz(rst!Payment_Made, 0) rst.Update End If rstE.MoveNext Next i rstE.Close: Set rstE = Nothing End If TheSum = Format(TheSum, "#,##0.00") MsgBox " " & "تم توزيع الإقتطاعات" & vbLf & vbLf & "مجموع الإقتطاعات = " & TheSum, , "إقتطاعات شهر" & FrenchMonth(Month(Date)) & Year(Date) I_am_Done: Case vbNo MsgBox "لم يتم توزيع الإقتطاعات" End Select rst.Close: Set rst = Nothing End If Exit Sub err_cmd_Pay_installments_Click: If Err.Number = 3021 Then Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub

انا فتحت النموذج طيب بعدين .... كيف يعمل برنامجك .... لكي نرى النتيجة ؟؟؟؟؟؟؟؟؟؟؟؟ في حال محاولة التشغيل يتوقف على Abou_Taha مما هذه ؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟

انت بحاجة الى نظام صلاحيات مجموعات ........ انظر المثال

اخي @كريمو2 المسألة ليس كلام صعوبة ولكن معليش حبه حبه ...... ارفق الملف الاخير الذي توصلت اليه ... ثم اعرض مطلوبك ... لاني تهت بين الردود الاكواد ....

جرب المرفق .... Test (30).accdb

تفضل جرب المرفق Test (30).accdb

هذا التصور العام لها بارك الله في .... يتبقى الترجمة لاكواد ....

جرب المرفق .... Test (29).accdb