Foksh

حسناً ..
سأقدم لك حلين اثنين ، ولربما سيكون هناك حلول أخرى من الأخوة والساتذة والمعلمين ..
الأول :-
باستخدام الدالة البسيطة التالية :-
Public Function Foksh_TXTK1() As String Dim rs As DAO.Recordset Dim result As String Set rs = CurrentDb.OpenRecordset("SELECT TXTK1 FROM Tablek WHERE TXTK1 Is Not Null", dbOpenSnapshot) Do While Not rs.EOF If rs!TXTK1 <> "" Then result = result & rs!TXTK1 & " , " End If rs.MoveNext Loop If Len(result) > 3 Then result = Left(result, Len(result) - 3) End If Foksh_TXTK1 = result rs.Close Set rs = Nothing End Function مع استخدام استعلام ليكون مصدر سجلات النموذج ، كمثال :-
SELECT Tablek.IDK, Tablek.Emp_Code, Tablek.TXTK1, Foksh_TXTK1() AS at_aziz FROM Tablek; لاحظ ان إسم الحقل الأخير (at_aziz) هو من سيعرض القيم ، وسيكون مصدر بيانات مربع النص TXT1 في نموذجك .
 
 
الثاني :-
باستخدام دالةبسيطة مشابهة تقريباً :-
Private Sub Foksh(frm As Form) Dim rs As DAO.Recordset Dim combinedText As String Set rs = frm.RecordsetClone rs.MoveFirst Do While Not rs.EOF If Not IsNull(rs!TXTK1) And rs!TXTK1 <> "" Then If combinedText <> "" Then combinedText = combinedText & " , " End If combinedText = combinedText & rs!TXTK1 End If rs.MoveNext Loop Me.TXT1.Value = combinedText rs.Close Set rs = Nothing End Sub ونستدعيها في حدث "في الحالي - Form_Current" ، بالشكل التالي :-
Private Sub Form_Current() Foksh Me End Sub  
 
مرفق الحلين :-
 
at_aziz.zip

وعليكم السلام ورحمة الله وبركاته ,,
جرب اكتب اي قيم رقمية وانقر كلمة يساوي
 
test.zip

وعليكم السلام ورحمة الله وبركاته ..
هل هذا هو المطلوب فعلاً ؟؟

فقط هذا الكود في حدث بعد التحديث للشيك بوكس :-
Private Sub CHK_AfterUpdate() Dim GradeValue As String If Me.CHK = -1 Then Select Case Me.نص74 Case "أولى" GradeValue = "1" Case "ثانية" GradeValue = "2" Case "ثالثة" GradeValue = "3" Case "رابعة" GradeValue = "4" Case "خامسة" GradeValue = "5" Case "سادسة" GradeValue = "6" Case Else GradeValue = Null End Select Me.نص76 = GradeValue Else Me.نص76 = Null End If End Sub  
sssssssss.zip

وعليكم السلام ورحمة الله وبركاته ..
جرب هذا الاستعلام إن كان ما فهمته صحيحاً ..
SELECT [1].[n], [1].[عميل], [1].[شراء], [1].[ثمن], (Len([شراء])-Len(Replace([شراء],"-",""))) AS [عدد العلامات] FROM 1;  
بهذا الشكل ستكون النتيجة :-
 
  n عميل شراء ثمن عدد العلامات 1 احمد - سجاد - مفرش - نجف 550 3 2 سيد - طقم معلق - طقم شتي - صنية - طقم حلل 1000 4 3 منال - طقم مدهب - بطانية 450 2  
 
 

وعليكم السلام ورحمة الله وبركاته ,,
مشكلتك في انك مكرر الدوال في 3 مديولات .. فقط احذف المديولين

hide form
fSetAccessWindowMared
 

وعليكم السلام ورحمة الله وبركاته ,,,
أخي بلال أسعد الله مساءكم وصباحكم في بلدنا العزيز الجزائر ..
استخدامك لكلمة ايقونة يسبب الإرباك لك في توصيل المعلومة الصحيحة .. ففي مثالك الإيقونة الحمراء هي في الواقع اسمها زر أو Button . لذا استخدم مسميات العناصر الصحيحة كي تساعد في توصيل المعلومة الصحيحة ..
بالنسبة لطلبك الأول فيما يتعلق بالزر الأحمر "إعادة" ، وإن كان ما فهمته صحيح .. استخدم هذا الحدث له
If Me.نص52 = "لا" Then Me.نص52 = "نعم" Else Me.نص52 = "لا" End If  
أما الطلب الثاني ، فقط قم بإضافة هذا الاستعلام
 
DoCmd.RunSQL "UPDATE [tblImportExcel] SET [معيد] = 'نعم' WHERE [السنة] = '" & [Forms]![ملفات التلاميذ]![السنة] & "';" بحيث تصبح الجملة الشرطية للرسالة عند اختيار = نعم :
If MsgBox(Msg, vbQuestion + vbMsgBoxRight + vbYesNo, "تأكيـــــد الإجــــــراء") = vbYes Then DoCmd.RunSQL "UPDATE [tblImportExcel] SET [معيد] = 'نعم' WHERE [السنة] = '" & [Forms]![ملفات التلاميذ]![السنة] & "';" DoCmd.RunSQL "UPDATE [tblImportExcel] Set [السنة]='" & NewYaer & "' where [السنة]=[forms]![ملفات التلاميذ]![السنة];" DoCmd.Requery End If  
ملفك بعد التعديل 
تحديد البرنامج1.zip

اخي أسعد ..
افتح الموذج في وضع التصميم ، واضغط Alt + F11 ليتم فتح محرر الأكواد . وستكون الأكواد أمامك كاملةً

المصيبة أعظم 😅
أعتقد توجهك الى بناء جديد يقوم بتخزين في ورقة منفصل جديدة باستخدام سجلات صفوف أفضل من سجلات الأعمدة ( طريقتك الحالية ) .

فقط قم بإزالة الجزء من Or لغاية 0
If IsNull(rs!evalu_moubadara_chaksia) Then  

وعليكم السلام ورحمة الله وبركاته ..
اعتقد تنسيق التاريخ في الحقل أو مربع النص له علاقة ، ولتلافي المشكلة وأعتقد مؤقتاً ، جرب التعديل التالي :-
DoCmd.OpenReport "Y_N_Report", acViewPreview, , "ddate = #" & Format([DDate], "yyyy-mm-dd") & "# AND NOT IsNull(colour)", , Screen.ActiveControl.Caption  

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

وعليكم السلام ورحمة الله وبركاته ..
حاولت التبسيط لك من خلال المعادلات و وجدت انك ستقوم بتكرار الكثير من المعادلات لكل عمود . لذا خطرت لي فكرة أبسط لك من خلال الكود التالي في زر  :-
Private Sub CommandButton1_Click() Dim wsSrc As Worksheet, wsDest As Worksheet Dim srcData As Variant, outData() As Variant Dim i As Long, j As Long, outRow As Long Dim lastRow As Long Set wsSrc = ThisWorkbook.Sheets("الوارد") 'تحديد الورقة المصدر Set wsDest = ThisWorkbook.Sheets("مشتريات") 'تحديد الورقة الهدف lastRow = wsSrc.Cells(wsSrc.Rows.Count, "F").End(xlUp).Row srcData = wsSrc.Range("B3:N" & lastRow).Value ' تم التوسيع حتى العمود N (عمود 14) ReDim outData(1 To UBound(srcData), 1 To 13) 'تحديد عدد الأعمدة outRow = 0 For i = 1 To UBound(srcData) If Trim(srcData(i, 5)) = "مشتريات" Then 'تحديد الشرط outRow = outRow + 1 For j = 1 To 13 'تحديد عدد الأعمدة outData(outRow, j) = srcData(i, j) Next j End If Next i If outRow > 0 Then wsDest.Range("B3").Resize(outRow, 13).Value = outData 'تحديد عدد الأعمدة End If End Sub  
وأضفت لك التعليقات لتفهم الفكرة في حال أردت التنفيذ على أوراق أو أفكار اخرى بتغيير الشروط والهدف والمصدر والأعمدة .... إلخ
الملف المرفق ، في الورقة "مشتريات" انقر الزر فقط 😁 .
 
 
خزينة المشتريات والتراخيص المركزية عام 2025-2026.xlsm

استخدم تحديث النموذج
Docmd.Requery بعد رسالة تأكيد نجاح الاستيراد 

وعليكم السلام ورحمة الله وبركاته ..
أولاً أخي الكريم ما علاقة النموذج الفرعي في حدث القرير !!!!!
حاول ان يكون العنوان ذا صلة بالموضوع وأن يكون واضحاً .
 
راجع هذا الموضوع ، سيفيدك كثيراً . فهو يحتوي ثمرة خبرة الأساتذة في هذا الموضوع 
 

هذه بسيطة إن شاء الله ,, لكن تعليقي على هذه :-
حيث ان عند تحويل الأوقات الى دقائق :-
300 + 360 + 300 + 300 + 389 + 300 + 375 + 366 + 270 + 380 + 300 + 380 + 375 + 270 + 330 + 300 + 375 + 375 + 300 + 375 + 300 = 7020 دقيقة وعند التحويل بقسمة المجموع على 60 7020 ÷ 60 = 117 ساعة  
إذاً الناتج يكون 117 ساعة ..
 
أما في طلبك الإضافي :-
SELECT Tbl_Salary.Mmonth, Format(Sum(DateDiff("n",[Start_Day],[End_Day]))\60,"00") & ":" & Format(Sum(DateDiff("n",[Start_Day],[End_Day])) Mod 60,"00") AS Total_Work_Time, Count(Tbl_Salary.ID) AS Work_Days, Round(Sum(DateDiff("n",[Start_Day],[End_Day]))/300,2) AS Actual_Work_Days FROM Tbl_Salary GROUP BY Tbl_Salary.Mmonth ORDER BY Min(Tbl_Salary.DDate);  
  Mmonth Total_Work_Time Work_Days Actual_Work_Days May 153:30 28 30.7 June 117:00 21 23.4 July 139:28 25 27.89 August 133:35 23 26.72

وعليكم السلام ورحمة الله وبركاته ,,
حل مشكلتك إن شاء الله بسيط . في المديول اللي في مشروعك الرئيسي ، انقل الدالة التالية :-
Public Function RowNum(frm As Form) As Variant On Error GoTo Err_RowNum With frm.RecordsetClone .Bookmark = frm.Bookmark RowNum = .AbsolutePosition + 1 End With Exit_RowNum: Exit Function Err_RowNum: If Err.Number <> 3021& Then Debug.Print "RowNum() error " & Err.Number & " - " & Err.Description End If RowNum = Null Resume Exit_RowNum End Function  
الآن في النموذج استدعي الدالة التالية في مربع النص الذي تريد الترقيم فيه بدلاً من القديمة :-
=RowNum([Form]) وأخبرنا بالنتيجة 

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

 
إن كانت صحيحة ، فقط نفس الكود السابق ولكن نقلب الإشارات الأكبر تصبح أصغر والعكس
Private Sub تفصيل_Paint() If Me.B3.Value < 9 Then Me.أمر56.Transparent = True Else Me.أمر56.Transparent = False End If End Sub Private Sub Form_Current() Dim bVisible As Boolean bVisible = (Me.B3.Value > 9 Or IsNull(Me.B3)) With Me.أمر56 .Transparent = Not bVisible .Enabled = bVisible End With End Sub  

حسناً أخي الكريم ، ما رأيك بتصحيح جزء من المشكلة بحيث تبدأ بفهم كيفية كتابة الأكواد بشكل مفهوم ؟؟
في الكود التالي زر الإضافة في المرحلة الأولى ، وقد أضفت شرحاً بسيطاً أتمنى ان يكون مفهوماً لك . مع العلم ان معظم مشاكلك كانت في تسمية الأوراق ( الورقة1 و الورقة2 ) حيث انهما غير موجودات أساساَ . بل اسمهما الصحيح في ملفك = Sheet1 و Sheet2 ...
انظر للكود وحاول مجاراته وفهمه . واستبدله في زر الإضافة وقم بالتنفيذ على باقي الأكواد بأسلوبك الذي فهمته . وإذا استعصى عليك شيء لا تتردد أو تبخل على نفسك بطرح السؤال .
 
Private Sub Cmdadd_Click() Dim wsSource As Worksheet Dim wsTarget As Worksheet Dim lastRow As Long ' هنا سنقوم بتحديد أسماء الأوراق المصدر والهدف Set wsSource = Worksheets("Sheet1") Set wsTarget = Worksheets("Sheet2") ' A هنا سنحاول البحث عن أول صف فارغ وتحديداً من العمود lastRow = 4 ' نبدأ من الصف 4 حسب تصميم الورقة الثانية لديك ' إذا كان الصف 4 غير فارغ ، نبحث عن أول صف فارغ أسفله If wsTarget.Cells(4, "A").Value <> "" Then lastRow = wsTarget.Cells(4, "A").End(xlDown).Row + 1 ' إذا وصلنا إلى نهاية البيانات (أي لا توجد خلايا فارغة) ، نستخدم آخر صف ونضيف له 1 If lastRow > wsTarget.Rows.Count Then lastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1 End If End If ' نتأكد من ان النطاق المحدد صحيح ويقع بين 4 وأكبر قيمة يسمح بها اكسل If lastRow < 4 Then lastRow = 4 If lastRow > wsTarget.Rows.Count Then lastRow = wsTarget.Rows.Count 'بدء نقل البيانات من الورقة الأولى إلى الورقة الثانية With wsSource wsTarget.Cells(lastRow, "A").Value = .Range("E5").Value wsTarget.Cells(lastRow, "B").Value = .Range("E7").Value wsTarget.Cells(lastRow, "C").Value = .Range("E9").Value wsTarget.Cells(lastRow, "D").Value = .Range("E11").Value wsTarget.Cells(lastRow, "E").Value = .Range("J5").Value wsTarget.Cells(lastRow, "F").Value = .Range("J7").Value wsTarget.Cells(lastRow, "G").Value = .Range("J9").Value wsTarget.Cells(lastRow, "H").Value = .Range("J11").Value wsTarget.Cells(lastRow, "I").Value = .Range("D13").Value wsTarget.Cells(lastRow, "J").Value = .Range("E13").Value wsTarget.Cells(lastRow, "K").Value = .Range("F13").Value wsTarget.Cells(lastRow, "P").Value = .Range("I13").Value wsTarget.Cells(lastRow, "Q").Value = .Range("J13").Value wsTarget.Cells(lastRow, "R").Value = .Range("K13").Value wsTarget.Cells(lastRow, "W").Value = .Range("D15").Value wsTarget.Cells(lastRow, "X").Value = .Range("E15").Value wsTarget.Cells(lastRow, "Y").Value = .Range("F15").Value wsTarget.Cells(lastRow, "AD").Value = .Range("I15").Value wsTarget.Cells(lastRow, "AE").Value = .Range("J15").Value wsTarget.Cells(lastRow, "AF").Value = .Range("K15").Value wsTarget.Cells(lastRow, "AK").Value = .Range("D17").Value wsTarget.Cells(lastRow, "AL").Value = .Range("E17").Value wsTarget.Cells(lastRow, "AM").Value = .Range("F17").Value wsTarget.Cells(lastRow, "AR").Value = .Range("I17").Value wsTarget.Cells(lastRow, "AS").Value = .Range("J17").Value wsTarget.Cells(lastRow, "AT").Value = .Range("K17").Value wsTarget.Cells(lastRow, "AY").Value = .Range("D19").Value wsTarget.Cells(lastRow, "AZ").Value = .Range("E19").Value wsTarget.Cells(lastRow, "BA").Value = .Range("F19").Value wsTarget.Cells(lastRow, "BF").Value = .Range("I19").Value wsTarget.Cells(lastRow, "BG").Value = .Range("J19").Value wsTarget.Cells(lastRow, "BH").Value = .Range("K19").Value wsTarget.Cells(lastRow, "BM").Value = .Range("D21").Value wsTarget.Cells(lastRow, "BN").Value = .Range("E21").Value wsTarget.Cells(lastRow, "BO").Value = .Range("F21").Value wsTarget.Cells(lastRow, "BT").Value = .Range("I21").Value wsTarget.Cells(lastRow, "BU").Value = .Range("J21").Value wsTarget.Cells(lastRow, "BV").Value = .Range("K21").Value End With ' مسح البيانات من الورقة الأولى On Error Resume Next ' تجاوز الأخطاء مؤقتًا Set rngToClear = wsSource.Range("E5,E7,E9,E11,J5,J7,J9,J11,D13:F13,I13:K13,D15:F15,I15:K15,D17:F17,I17:K17,D19:F19,I19:K19,D21:F21,I21:K21") For Each cell In rngToClear If Not cell.MergeCells Then ' إذا لم تكن الخلية جزءً من دمج cell.ClearContents Else ' إذا كانت الخلية جزءً من دمج cell.MergeArea.ClearContents ' مسح محتوى نطاق الدمج بالكامل End If Next cell On Error GoTo 0 ' إعادة تفعيل مكتشف الأخطاء MsgBox "تم ترحيل البيانات بنجاح", vbInformation + vbMsgBoxRight, "تم" End Sub  

وعليكم السلام ورحمة الله وبركاته ..
تم إضافة دالة جديدة لإنشاء الجدول المؤقت الجديد "zTempImageReport" ، حيث يتم فيه اضافة سجلات الصور ومساراتها :-
Public Function CreateTempImageTable() On Error GoTo ErrorHandler Dim db As DAO.Database Dim tdf As DAO.TableDef Dim fld As DAO.Field Dim tblExists As Boolean Set db = CurrentDb() tblExists = False For Each tdf In db.TableDefs If tdf.Name = "zTempImageReport" Then tblExists = True Exit For End If Next tdf If Not tblExists Then Set tdf = db.CreateTableDef("zTempImageReport") Set fld = tdf.CreateField("ImageName", dbText, 255) tdf.Fields.Append fld Set fld = tdf.CreateField("ImagePath", dbText, 255) tdf.Fields.Append fld Set fld = tdf.CreateField("EmployeeID", dbLong) tdf.Fields.Append fld Set fld = tdf.CreateField("EmployeeName", dbText, 100) tdf.Fields.Append fld db.TableDefs.Append tdf Else db.Execute "DELETE * FROM zTempImageReport", dbFailOnError End If Exit Function ErrorHandler: MsgBox " : حدث خطأ في إعداد الجدول المؤقت" & Err.Description, vbCritical + vbMsgBoxRight, "" Exit Function End Function  
قمت بإنشاء التقرير "rptImageGallery" ، والذي مصدر سجلاته = الجدول المؤقت السابق "zTempImageReport" ، وفي النموذج في الزر "أمر105" الكود التالي :-
Private Sub أمر105_Click() On Error GoTo ErrorHandler If List31.ListCount = 0 Then MsgBox "لا توجد صور ليتم عرضها في التقرير", vbInformation + vbMsgBoxRight, "" Exit Sub End If Call CreateTempImageTable Dim db As DAO.Database Dim rs As Recordset Dim i As Integer Dim ImagePath As String Dim basePath As String basePath = CurrentProject.Path & "\SysFiles\" & Me.ID & "\" Set db = CurrentDb() db.Execute "DELETE * FROM zTempImageReport", dbFailOnError For i = 0 To List31.ListCount - 1 If List31.ItemData(i) <> "" Then ImagePath = basePath & List31.ItemData(i) If Dir(ImagePath) <> "" Then db.Execute "INSERT INTO zTempImageReport " & _ "(ImageName, ImagePath, EmployeeID, EmployeeName) " & _ "VALUES ('" & Replace(List31.ItemData(i), "'", "''") & "', " & _ "'" & Replace(ImagePath, "'", "''") & "', " & _ Me.ID & ", '" & Replace(Me.الاسم, "'", "''") & "')", dbFailOnError End If End If Next i DoCmd.OpenReport "rptImageGallery", acViewPreview Exit Sub ErrorHandler: MsgBox " : حدث خطأ أثناء فتح التقرير" & Err.Description, vbCritical + vbMsgBoxRight, "" End Sub  
هي فكرة بسيطة تلبي حاجتك ، وتستطيع التعديل عليها حسب حاجتك .
الملف بعد التعديل :-
 
الصورة (1).zip

تمام ، هكذا الأمور أوضح للجميع ,,
تفضل هذا الكود كاملاً للنموذج بعد التعديل :-
 
Option Compare Database Private m_ImagePath As String Sub ImageLoad() On Error Resume Next m_ImagePath = CurrentProject.Path & "\" & "SysFiles" & "\" & Me.ID List31.RowSource = "" List31.RowSource = Left(GetAllFile(m_ImagePath), Len(GetAllFile(m_ImagePath)) - 1) End Sub Private Sub Command42_Click() On Error Resume Next m_ImagePath = CurrentProject.Path & "\SysFiles\" & Me.ID Dim newFileName As String newFileName = AddNewFile(Me.ID) Image16.Picture = m_ImagePath & "\" & newFileName Call ImageLoad Me.Path = m_ImagePath & "\" & newFileName If Not IsNull(newFileName) Then List31.Value = newFileName End If End Sub Private Sub Command43_Click() On Error Resume Next If IsNull(List31) Then Exit Sub If MsgBox("هل تريد فعلا حذف الصورة المحددة" & vbNewLine & List31, vbMsgBoxRight + vbYesNo + vbQuestion, "تأكيد الحذف") = vbYes Then m_ImagePath = CurrentProject.Path & "\" & "SysFiles" & "\" & Me.ID Kill (m_ImagePath & "\" & List31) Call ImageLoad Image16.Picture = "" Image16.Requery End If End Sub Private Sub Form_Current() On Error Resume Next Call ImageLoad Me.Form.Caption = IIf(IsNull(Me.الاسم), "", Me.الاسم) Image16.Picture = "" Auto_Header0.Caption = "الأرشيف الالكتروني للموظف" & " : " & Me.الاسم End Sub Private Sub List31_Click() On Error Resume Next m_ImagePath = CurrentProject.Path & "\" & "SysFiles" & "\" & Me.ID Image16.Picture = m_ImagePath & "\" & List31 Me.Path = m_ImagePath & "\" & Me.List31 End Sub Private Sub List31_DblClick(Cancel As Integer) On Error Resume Next If IsNull(List31.Value) Or List31.Value = "" Then Exit Sub Dim oldName As String, oldNameWithoutExt As String, fileExt As String Dim filePath As String, newName As String, newNameWithExt As String oldName = List31.Value filePath = CurrentProject.Path & "\SysFiles\" & Me.ID & "\" Dim dotPosition As Integer dotPosition = InStrRev(oldName, ".") If dotPosition > 0 Then oldNameWithoutExt = Left(oldName, dotPosition - 1) fileExt = Mid(oldName, dotPosition) Else oldNameWithoutExt = oldName fileExt = "" End If newName = InputBox("أدخل الاسم الجديد للصورة", "تعديل اسم الصورة", oldNameWithoutExt) If newName = "" Or newName = oldNameWithoutExt Then Exit Sub newNameWithExt = newName & fileExt If Dir(filePath & oldName) <> "" Then If Dir(filePath & newNameWithExt) <> "" And LCase(filePath & newNameWithExt) <> LCase(filePath & oldName) Then MsgBox "! يوجد ملف بهذا الاسم بالفعل", vbExclamation + vbMsgBoxRight, "" Exit Sub End If Name filePath & oldName As filePath & newNameWithExt Call ImageLoad List31.Value = newNameWithExt If Image16.Picture = filePath & oldName Then Image16.Picture = filePath & newNameWithExt Me.Path = filePath & newNameWithExt End If MsgBox "تم تعديل اسم الصورة بنجاح", vbInformation + vbMsgBoxRight, "" Else MsgBox "الصورة التي تحاول تغيير اسمها ، غير موجودة في مجلد الموظف", vbExclamation + vbMsgBoxRight, "" End If End Sub  
الملف :-


 
الصورة.zip

أخي الكريم ، اذا كنت تريد التنفيذ من خلال الزر ويكون كما في فكرة الأستاذ @Barna ، فتفضل هذا الحدث جربه ، وأخبرنا بالنتيجة :-
Public Sub UpdateFinalGrades() Dim db As DAO.Database Dim rs As DAO.Recordset Dim strSQL As String Dim fld As DAO.Field Dim subjects As Variant subjects = Array("Arb", "Math", "Drast", "Since", "Eng", "Comp", "Skills", "Den") On Error GoTo ErrorHandler Set db = CurrentDb() strSQL = "SELECT * FROM data_dor2 WHERE name_student <> 'IsNull'" Set rs = db.OpenRecordset(strSQL, dbOpenDynaset, dbSeeChanges) If rs.RecordCount = 0 Then MsgBox "لا توجد سجلات ليتم تحديثها", vbInformation + vbMsgBoxRight, "" Exit Sub End If Do Until rs.EOF For Each subj In subjects Dim dor1 As String, dor2 As String, final As String dor1 = "Dor_" & subj dor2 = "TDor_" & subj final = "N_" & subj If Nz(rs.Fields(dor1).Value, 0) = -1 Or Nz(rs.Fields(dor2).Value, 0) = -1 Then rs.Edit rs.Fields(final).Value = -1 rs.Update Else Dim grade As Double If IsNumeric(rs.Fields(dor1).Value) Then If rs.Fields(dor1).Value >= 50 Then grade = rs.Fields(dor1).Value Else If IsNull(rs.Fields(dor2).Value) Then grade = 0 ElseIf rs.Fields(dor2).Value >= 50 Then grade = 50 Else grade = rs.Fields(dor2).Value End If End If rs.Edit rs.Fields(final).Value = grade rs.Update End If End If Next subj rs.MoveNext Loop DoCmd.Requery MsgBox "تم تحديث جميع الدرجات بنجاح", vbInformation + vbMsgBoxRight, "" Exit Sub ErrorHandler: MsgBox " : حدث خطأ" & Err.Description, vbCritical + vbMsgBoxRight, "" rs.CancelUpdate If Not rs Is Nothing Then rs.Close Set rs = Nothing Set db = Nothing End Sub  
تستطيع استخدامه في مديول واستدعائه من خلال الزر بإسم الدالة فقط :-
Private Sub أمر309_Click() UpdateFinalGrades End Sub  
أما استعلام التحديث السابق فتجاهله ، وجرب الطريقة الحالية .
الملف المرفق قبل لا أنسى 😅 
 
cont0.zip

وعليكم السلام ورحمة الله وبركاته ..
مشكلتك اذا ما خاب ظني ، هي في عدم اضافة المكتبة الموضحة في الصورة التالية :-

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

طيب ، على حسب ما فهمت من مناقشات سابقة بهذا الخصوص ، جرب هذا التعديل :-
Private Sub أمر322_Click() On Error GoTo ErrHandler If DCount("*", "data_dor2", "Not IsNull(n_lgna_dor2)") > 0 Then MsgBox "عفوا .. تم إضافة وترقيم اللجان من قبل", vbCritical + vbMsgBoxRight, "" Exit Sub End If If IsNull(Me.studen_lg) Or Me.studen_lg <= 0 Then MsgBox "عزيزى مدخل البيانات .. من فضلك ضع عدد التلاميذ المطلوبة فى كل لجنة قبل التنفيذ", vbCritical + vbMsgBoxRight, "" Exit Sub End If If IsNull(Me.start_lg) Then MsgBox "عزيزى مدخل البيانات من فضلك ضع بداية ترقيم اللجان قبل التنفيذ", vbCritical + vbMsgBoxRight, "" Exit Sub End If Dim rs As DAO.Recordset Dim lgCounter As Long Dim stdPerGroup As Long Dim i As Long Set rs = Me.RecordsetClone rs.MoveFirst lgCounter = Me.start_lg stdPerGroup = Me.studen_lg i = 0 Do While Not rs.EOF rs.Edit rs!n_lgna_dor2 = lgCounter rs.Update i = i + 1 If i Mod stdPerGroup = 0 Then lgCounter = lgCounter + 1 End If rs.MoveNext Loop Me.Requery MsgBox "تم توزيع الطلاب على اللجان بنجاح", vbInformation + vbMsgBoxRight, "" Exit Sub ErrHandler: MsgBox " : حدث خطأ" & Err.Description, vbCritical + vbMsgBoxRight, "" End Sub  

وعليكم السلام ورحمة الله وبركاته ..
تستطيع ذلك من خلال ملفك المرفق كالآتي :-
 
في الخلية B5 ( لحساب الأيام ) :-
=MOD(B3+B4,30) في الخلية C5 ( لحساب الأشهر ) :-
=MOD(C3+C4+QUOTIENT(B3+B4,30),12) في الخلية D5 ( لحساب السنوات ) :-
=D3+D4+QUOTIENT(C3+C4+QUOTIENT(B3+B4,30),12)  
وتستطيع أيضاً عرض التفصيل كاملاً في خلية واحدة . على سبيل المثال . قمت بدمج الخلايا B+C+D = 6 في خلية واحدة ، وأدرجت فيها المعادلة التالية :-
=D3+D4+QUOTIENT(C3+C4+QUOTIENT(B3+B4,30),12) & " سنوات, " & MOD(C3+C4+QUOTIENT(B3+B4,30),12) & " أشهر, " & MOD(B3+B4,30) & " أيام"  
وهذه صورة من النتيجة النهائية :-
 
 

 
 
 
 
Number of Serveces.zip

بدايةً الخطأ ان اسم مربع النص ID وليس الكود !!
ثانياً لازم تمرر مسار واسم النموذج الفرعي اللي موجود فيه الشرط ID .
وفي الدالة :-
Public Function f11(الكود As Integer) DoCmd.OpenForm "Customer Details", , , "[الكود] = " & الكود End Function لا يتم تمرير الشرط أو المعيار للفلترة . لذا توجهت الى فكرة غريبة نوعاً ما بحيث من خلال الكود يتم البحث عن أول نموذج فرعي يحتوي مربع النص ID كشرط ومعيار للفلترة وتمريره الى جملة فتح النموذج على السجل المحدد . لتصبح الدالة مع مساعد بسيط :-
'---------- ( ID تم التعديل هنا بحيث يتم البحث عن أول نموذج فرعي يحتوي مربع النص ) ---------- Public Function f11() On Error GoTo ErrHandler Dim frmMain As Form Dim ctrl As Control Dim frmSub As Form Dim val As Variant Set frmMain = Screen.ActiveForm For Each ctrl In frmMain.Controls If ctrl.ControlType = acSubform Then Set frmSub = ctrl.Form If HasControl(frmSub, "ID") Then val = frmSub.Controls("ID").Value DoCmd.OpenForm "Customer Details", , , "[الكود] = " & val Exit Function End If End If Next ctrl MsgBox ". 'ID' لم يتم العثور على نموذج فرعي يحتوي على الشرط", vbExclamation + vbMsgBoxRight, "" Exit Function ErrHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical + vbMsgBoxRight, "" End Function Private Function HasControl(frm As Form, ctrlName As String) As Boolean On Error Resume Next HasControl = Not frm.Controls(ctrlName) Is Nothing End Function '---------- ( نهاية التعديل ) ----------  
ملفك بعد التعديل :-
 
date-2025 - Copy (4).zip