ناقل

تم تعديل الملف :::::::::::::
عدلنا الحقل CorrectionCommittee في الجدول Teachers الى تاريخ/وقت
عدلنا الكود تحت الزر بهذا الشكل ........
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 Dim teacherAssignedA As Boolean, teacherAssignedB As Boolean Dim dayKey As String Dim safeName As String Dim teacherName As String On Error GoTo ErrorHandler Set db = CurrentDb() ' 1. التهيئة: مسح الجدول وتصفير العدادات db.Execute "UPDATE Teachers SET SupervisionCount = 0" db.Execute "DELETE FROM TeacherAssignment" ' 2. التحقق من توفر عدد كافٍ من المعلمين Dim totalSupervisionsNeeded As Long Dim availableA As Long, availableB As Long Dim daysCount As Long, roomsCount As Long daysCount = DCount("*", "SupervisionDays") roomsCount = DCount("*", "ExamRooms") totalSupervisionsNeeded = daysCount * roomsCount ' معلم A ومعلم B لكل قاعة ' حساب المعلمين المتاحين مع مراعاة جميع شروط الاستثناء ' (هنا نستخدم شرط التحقق من تاريخ المراقبة فقط) availableA = DCount("*", "Teachers", "TeacherCategory = 'A' " & _ "AND (ExamDate Is Null OR ExamDate Not In (SELECT SupervisionDate FROM SupervisionDays))") availableB = DCount("*", "Teachers", "TeacherCategory = 'B' " & _ "AND (ExamDate Is Null OR ExamDate Not In (SELECT SupervisionDate FROM SupervisionDays))") If availableA < totalSupervisionsNeeded Or availableB < totalSupervisionsNeeded Then Dim response As VbMsgBoxResult response = MsgBox("تحذير: عدد المعلمين غير كافي!" & vbCrLf & _ "المطلوب: " & totalSupervisionsNeeded & " معلم A و " & totalSupervisionsNeeded & " معلم B" & vbCrLf & _ "المتاح: " & availableA & " معلم A و " & availableB & " معلم B" & vbCrLf & _ "هل تريد المتابعة مع وضع 'غير مغطاة' للقاعات غير المكتملة؟", _ vbYesNo + vbExclamation, "تنبيه") If response = vbNo Then MsgBox "تم إلغاء التوزيع بناءً على طلبك.", vbInformation Exit Sub End If End If ' 3. بدء عملية التوزيع 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 dailyTeachers As Object Set dailyTeachers = CreateObject("Scripting.Dictionary") ' حلقة على كل الأيام Do While Not rsDays.EOF supervisionDate = rsDays!supervisionDate ' تهيئة القاموس لهذا اليوم فقط (ليسمح بالتكرار في الأيام الأخرى) dailyTeachers.RemoveAll ' حلقة على كل القاعات rsRooms.MoveFirst Do While Not rsRooms.EOF roomName = rsRooms!roomName teacherAssignedA = False teacherAssignedB = False ' تعيين معلم فئة A Set rsA = db.OpenRecordset("SELECT * FROM Teachers WHERE TeacherCategory='A' " & _ "AND (ExamDate Is Null OR ExamDate <> #" & Format(supervisionDate, "mm/dd/yyyy") & "#) " & _ "AND (CorrectionCommittee Is Null OR CorrectionCommittee <> #" & Format(supervisionDate, "mm/dd/yyyy") & "#) " & _ "ORDER BY SupervisionCount ASC", dbOpenDynaset) If Not rsA.EOF Then rsA.MoveFirst Do Until rsA.EOF Or teacherAssignedA teacherName = rsA![teacherName] If Not dailyTeachers.Exists(teacherName) Then ' تعيين المعلم A rsTarget.AddNew rsTarget!teacherName = teacherName rsTarget!TeacherCategory = "A" rsTarget!ExamRoom = roomName rsTarget!supervisionDate = supervisionDate rsTarget.Update ' تحديث العداد safeName = Replace(teacherName, "'", "''") db.Execute "UPDATE Teachers SET SupervisionCount = SupervisionCount + 1 WHERE [TeacherName] = '" & safeName & "'" ' إضافة المعلم للقاموس اليومي فقط dailyTeachers.Add teacherName, 1 teacherAssignedA = True End If rsA.MoveNext Loop End If rsA.Close ' إذا لم يتم تعيين معلم A، تسجيل "غير مغطاة" If Not teacherAssignedA Then rsTarget.AddNew rsTarget!teacherName = "غير مغطاة" rsTarget!TeacherCategory = "A" rsTarget!ExamRoom = roomName rsTarget!supervisionDate = supervisionDate rsTarget.Update End If ' تعيين معلم فئة B Set rsB = db.OpenRecordset("SELECT * FROM Teachers WHERE TeacherCategory='B' " & _ "AND (ExamDate Is Null OR ExamDate <> #" & Format(supervisionDate, "mm/dd/yyyy") & "#) " & _ "AND (CorrectionCommittee Is Null OR CorrectionCommittee <> #" & Format(supervisionDate, "mm/dd/yyyy") & "#) " & _ "ORDER BY SupervisionCount ASC", dbOpenDynaset) If Not rsB.EOF Then rsB.MoveFirst Do Until rsB.EOF Or teacherAssignedB teacherName = rsB![teacherName] If Not dailyTeachers.Exists(teacherName) Then ' تعيين المعلم B rsTarget.AddNew rsTarget!teacherName = teacherName rsTarget!TeacherCategory = "B" rsTarget!ExamRoom = roomName rsTarget!supervisionDate = supervisionDate rsTarget.Update ' تحديث العداد safeName = Replace(teacherName, "'", "''") db.Execute "UPDATE Teachers SET SupervisionCount = SupervisionCount + 1 WHERE [TeacherName] = '" & safeName & "'" ' إضافة المعلم للقاموس اليومي فقط dailyTeachers.Add teacherName, 1 teacherAssignedB = True End If rsB.MoveNext Loop End If rsB.Close ' إذا لم يتم تعيين معلم B، تسجيل "غير مغطاة" If Not teacherAssignedB Then rsTarget.AddNew rsTarget!teacherName = "غير مغطاة" rsTarget!TeacherCategory = "B" rsTarget!ExamRoom = roomName rsTarget!supervisionDate = supervisionDate rsTarget.Update End If rsRooms.MoveNext Loop rsDays.MoveNext Loop ' 4. التنظيف وإغلاق الموارد rsTarget.Close rsRooms.Close rsDays.Close Set rsTarget = Nothing Set rsRooms = Nothing Set rsDays = Nothing Set rsA = Nothing Set rsB = Nothing Set db = Nothing Set dailyTeachers = Nothing MsgBox "تم الانتهاء من التوزيع بنجاح!" & vbCrLf & _ "تم تعيين معلم A ومعلم B لكل قاعة" & vbCrLf & _ "مع مراعاة الشروط التالية:" & vbCrLf & _ "- عدم تكرار المعلم في نفس اليوم" & vbCrLf & _ "- السماح بتكرار المعلم في أيام مختلفة" & vbCrLf & _ "- استثناء المعلمين الذين لديهم اختبار في نفس اليوم" & vbCrLf & _ "- استثناء المعلمين الموجودين في لجنة تصحيح لنفس تاريخ المراقبة فقط" & vbCrLf & _ "- العدالة في التوزيع حسب عدد المراقبات السابقة", _ vbInformation, "إنجاز" Exit Sub ErrorHandler: MsgBox "حدث خطأ أثناء التنفيذ: " & vbCrLf & _ "رقم الخطأ: " & Err.Number & vbCrLf & _ "الوصف: " & Err.Description & vbCrLf & _ "في الإجراء: " & Erl, vbCritical, "خطأ" Resume Next تقضل المرفق .......................
 
‏‏NA_3.accdb

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

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

مشاركة
Sub ClearClipboardAndFreeMemory() ' تحرير محتوى الحافظة On Error Resume Next Dim DataObject As Object Set DataObject = CreateObject("MSForms.DataObject") DataObject.SetText "" DataObject.PutInClipboard Set DataObject = Nothing On Error GoTo 0 ' تحرير الذاكرة DoEvents Application.Echo True, "Memory cleared" End Sub  

جرب هذا ....
Private Sub Form_Open(Cancel As Integer) Me.OrderBy = "fega ASC" ' للفرز تصاعديًا Me.OrderByOn = True End Sub Private Sub Form_Current() Me.OrderBy = "fega ASC" ' للفرز تصاعديًا Me.OrderByOn = True End Sub  

جرب المرفق
 
open.accdb
Private Sub Form_Load() Call CopyText("Pa@ 12345678") End Sub Public Function CopyText(ByVal Text As Variant) As Boolean CopyText = CreateObject("htmlfile").ParentWindow.ClipboardData.SetData("Text", Text) End Function  

جرب كده
Private Sub Form_Current() Dim ctl As Control ' التحقق من قيمة الحقل MAN If Me.MAN = "HTM" Then ' اجعل جميع الحقول غير قابلة للتحرير For Each ctl In Me.Controls If ctl.ControlType = acTextBox Or ctl.ControlType = acComboBox Then ctl.Locked = True End If Next ctl ' السماح بتعديل الحقول الثلاثة فقط Me.INFU.Locked = False Me.MUR.Locked = False Me.POL.Locked = False Else ' إذا لم يتحقق الشرط، اجعل جميع الحقول غير قابلة للتعديل For Each ctl In Me.Controls If ctl.ControlType = acTextBox Or ctl.ControlType = acComboBox Then ctl.Locked = True End If Next ctl End If End Sub  

احسن انه في تناقض في كلامك ..... كيف برنامجك ترقيم غير مكرر وانت تتعمد اضافة سجل برقم مكرر ولا تريد رسالة الخطأ ....!!!!!!!!!! ؟؟؟؟؟
اضف السجل بدون اضافة رقم والبرنامج هو المسؤل عن الترقيم .... ثم يعيد ترتيب الارقام حسب تسلسل التاريخ .......
جرب ملفي بالطريقة التي ذكرتها لك دون ان تسجل او تغير الرقم الظاهر في مربع النص ....

جرب كده .....
 
‏‏جديد - نسخة.accdb

طبق كما في الصورة ................
 

ولماذا لايكون التاريخ تلقائي حسب السنة الدراسية .... دون الحاجة لارتباطها بالنموذج ؟؟؟

استبدل عبارة sql الموجود في الاستعلام بهذا 
UPDATE [2024 misr pharma expenses] INNER JOIN CASH_OUT_ACCOUNT_EXPENSES_DETAILS_MPC ON [2024 misr pharma expenses].auto_number_excel = CASH_OUT_ACCOUNT_EXPENSES_DETAILS_MPC.excel_access_id SET CASH_OUT_ACCOUNT_EXPENSES_DETAILS_MPC.[cash usd out] = [2024 misr pharma expenses].[cash usd out x];  

تفضل ...............................
 


مستندات.accdb

الحمد لله رب العالمين .... واشكرك على هذه الدعوات التي نحتاجها ولك بمثل ما دعوت اخي الكريم
هذا ما يحدث قي المرفق الموجود في الموضوع ..... انظر المرفق
اضفت كود بسيط لذلك انظر ان جاز لك استخدمه
 
Database1.accdb
ملاحظة ::::::
حاول عدم استخدام طريقة المرفق داخل القاعدة لأنها تتسبب في تضم القاعدة وقدتتلف .... استخدم طريقة المرفق داخل مجلد بجوار القاعدة ... ابحث عنها في المنتدى أفضل ...

طيب ... بارك الله فيك ::::::
انظر الى الجدول tbl_Teachers تم ادراج البيانات المطلوبة مثل الوظيفة
وفي جدول الحضور heures_effectuées_rapport حسب بياناتك اعتمدنا على الاسم  تدوين اسم الموظف والتاريخ ( هل تريد حساب تأخر للموظف مستقبلا ام لا ...... ) لاني تركتها حسب التاريخ فقط
=== وهنا الخلاصة ( في الاستعلام ) تم استخراج اسم الموظف وتاريخ الحضور والوظيفة بدون تسجيلها في جدول الحضور  وبهذا لم نكرر الوظيفة في جدول الحضور 
مرفق المثال :::
 



BASEM (2).accdb

انظر هنا ......
 

جرب المرفق <<<<<
 
Database32.accdb

وهذه طريقة اخرى من الذكاء .....
يجب وضع هذا الكود في النموذج الذي ترغب في تغيير رسالة التكامل المرجعي الخاصة به. عندما يحدث خطأ 3200 الذي يشير إلى رسالة التكامل المرجعي، ستظهر الرسالة الجديدة المحددة في الكود بدلاً من الرسالة الافتراضية. Private Sub Form_Error(DataErr As Integer, Response As Integer) ' رسالة التكامل المرجعي - Reference Integrity Message If DataErr = 3200 Then ' قم بتعديل الرسالة الجديدة هنا MsgBox "رسالة جديدة" Response = acDataErrContinue End If End Sub  
     

Gyab_2.rar

دالة الوقت والتاريخ.rar

وانت في صحة وسلامة 
طيب انشئ وحدة نمطية وضع هذا فيه :::::::
Private Const TIMEOUT = 99 Public Sub Restart() Dim scriptpath As String scriptpath = Application.CurrentProject.FullName & ".dbrestart.bat" If Dir(scriptpath, vbNormal) <> "" Then If DateAdd("s", TIMEOUT * 1, FileDateTime(scriptpath)) < Date Then Kill scriptpath Else Application.Quit acQuitSaveAll Exit Sub End If End If Dim s As String s = s & "SETLOCAL ENABLEDELAYEDEXPANSION" & vbCrLf s = s & "SET /a counter=0" & vbCrLf s = s & ":CHECKLOCKFILE" & vbCrLf s = s & "ping 0.0.0.255 -n 1 -w 100 > nul" & vbCrLf s = s & "SET /a counter+=1" & vbCrLf s = s & "IF ""!counter!""==""" & TIMEOUT & """ GOTO CLEANUP" & vbCrLf s = s & "IF EXIST ""%~f1.%3"" GOTO CHECKLOCKFILE" & vbCrLf s = s & "start "" "" ""%~f1.%2""" & vbCrLf s = s & ":CLEANUP" & vbCrLf s = s & "del %0" Dim intFile As Integer intFile = FreeFile() Open scriptpath For Output As #intFile Print #intFile, s Close #intFile Dim dbname As String, ext As String, lockext As String Dim idx As Integer For idx = Len(CurrentProject.FullName) To 1 Step -1 If Mid(CurrentProject.FullName, idx, 1) = "." Then Exit For Next idx dbname = Left(CurrentProject.FullName, idx - 1) ext = Mid(CurrentProject.FullName, idx + 1) If Left(ext, 2) = "ac" Then lockext = "laccdb" Else lockext = "ldb" End If s = """" & scriptpath & """ """ & dbname & """ " & ext & " " & lockext Shell s, vbHide Application.Quit acQuitSaveAll End Sub  
تحت حدث الزر ضع هذا ::::::::
Utilities.Restart  

تفضل ...
DoCmd.RunCommand acCmdPageSetup  

تفضل ...
DoCmd.RunCommand acCmdPageSetup  

تفضل ...
DoCmd.RunCommand acCmdPageSetup  

جرب هذا في حقل التاريخ .....
Between [Forms]![نموذج_بحث]![from] And [Forms]![نموذج_بحث]![to]  

طيب أهلا عمر .... جرب هل هذا ما تريد ؟؟
On Error GoTo Errw Dim i As Integer DoCmd.GoToRecord , , acFirst For i = 1 To Me.Recordset.RecordCount If Me.Emp_ABSCENT = False Then txtTimeIn.Value = Time Else txtTimeIn.Value = "" End If DoCmd.GoToRecord , , acNext Next i Exit Sub Errw: MsgBox "لقد تم اعتماد الحضور بنجاح بنجاح", vbOKOnly  
حضور وانصراف موظفين.accdb