كل الانشطه

أنت كمان بتضحك حظك لإنى مش فاضى لك بس نكاش بنكاش والبادى أنكش ... وأنت اللى بدأت بئه انا مش فاهم انا بقول ايه شكلى وصلت لاخر السكة خلاص التكة خلصت اتفضل يا سيدى ذاكر وانبسط بما انك عاوز وحده نمطية وتحكم من خلالها بس مش هخليها زيك تخفى العناصر وخلاص لا هخليــ .... وهأتكلم كتير ما تشوف بنفسك المرفق فيه الـ 3 نماذج بتوعك زى ما هم بينفذوا نفس طلابتك بس .......... فى نموذجين تانين ووحدتين نمطيتين شوف انت بقه اللى فيهم وذاكر ولما ابقى أروق لك ونفضى نبقى نتشاكس الموضوع والمرفق : >--->> من هنا يا أستاذ @Foksh طبعا بعيدا عن التهريج والهزار والمزاح لا اقلل من الاجابة الاولى وهى قطعا وبالفعل الأفضل على الإطلاق والإجابة المباشرة ولكن لأن فعلا كان فكرة كنت شغال عليها بالصدفة وتقريبا كانت شبه منتهيه فى ترتيب الأفكار بس لإؤش أفندى بقه لعب فى نفوخى قلت لا بقه لازم أنهى الفكرة بالشكل الأمثل وعلشان مرتبطه بالموضوع ده وهو تنفيذ حدث فى وقت محدد أو بين وقتين محددين حبت اهزر الورد وأضحك مع أخى الحبيب فؤش أفندى بمناسبة أن دى أول مشاركه لى معه بثوبه الجديد وليكون الموضوع مرجعا لمن يهتم لمثل هذه الأمور المجنونه شويه شويه هتخلونا نعمل كود يعمل اللى بنفكر ونحلم بيه ده اللى ناقص بقه وتبقى كملت مش تقولوا لى كود يعمل اكتر من وظيفه أو وظائف متتعده فى وقت محدد أو فى عدة أوقات مختلفة من إجراء واحد مركزى ايه لعب العيال ده يا فؤش أفندى هههه وأنا مصدقت لاقيته لعب عيال قلت العب براحتى بقه بقالى كتير ما أفوت وأول ما أفوت اشوفك ما شاء الله لابس البدله الحمرا

الوحده النمطية الأولى: bas01:TimeAction المميزات أنواع أحداث وتعليقات قابلة للتوسعة عبر Enum (EventType, ControlVisibility) تحديد توقيت إظهار/إخفاء عناصر النماذج بسهولة عبر الدالة SetControlVisibility تنفيذ إجراءات مؤقتة باستخدام CallTimeAction أو ApplyTimeActions منع التكرار التلقائي للتنفيذ بالدالة الذكية ExecuteDynamicMethod دعم المعاملات وتعددها في الدوال المنفذة (حتى 4 معاملات) تسجيل احترافي للأحداث عبر LogEvent في نافذة Immediate شرط تفعيل DebugMode الهدف : تنفيذ إجراءات مشروطة بالوقت مع إمكانية التنفيذ لمرة واحدة في الجلسة الاستخدام الأمثل :تحكم في ظهور عناصر/عدة عناصر بالنموذج أو تنفيذ إجراء/إجراءات بناء على الوقت اليومي استخدم الكود فى الحالات الآتيـــة : إذا كنت تحتاج إلى تنفيذ إجراءات زمنية عادية ومكررة يوميا إذا كنت لا تمانع في تنفيذ نفس الدالة مرات مختلفة إذا تغيّر التوقيت Option Compare Database Option Explicit ' ========================= ' إعدادات عامة ' ========================= Public DebugMode As Boolean Private dicExecuted As Object ' لتجنب تكرار التنفيذ ' ========================= ' أنواع الأحداث والمظهر ' ========================= Public Enum ControlVisibility visible = 0 Hidden = 1 ErrorState = 2 End Enum Public Enum EventType Information = 0 Warning = 1 [Error] = 2 End Enum ' ========================= ' تهيئة الوحدة ' ========================= Private Sub InitializeModule() If dicExecuted Is Nothing Then Set dicExecuted = CreateObject("Scripting.Dictionary") dicExecuted.CompareMode = vbTextCompare End If End Sub ' ========================= ' إعادة تعيين السجل ' ========================= Public Sub ResetExecutedLog() If Not dicExecuted Is Nothing Then dicExecuted.RemoveAll End Sub ' ========================= ' أدوات مساعدة عامة ' ========================= Public Sub LogEvent(message As String, Optional msgType As EventType = Information) If DebugMode Then Debug.Print Format(Now, "yyyy-mm-dd hh:nn:ss") & " [TimedAction] " & _ Choose(msgType + 1, "INFO", "WARN", "ERR") & ": " & message End If End Sub Private Function IsFormName(ByVal varValue As Variant) As Boolean On Error GoTo ErrHandler If VBA.TypeName(varValue) = "String" Then If SysCmd(acSysCmdGetObjectState, acForm, CStr(varValue)) = acObjStateOpen Then IsFormName = True End If End If Exit Function ErrHandler: IsFormName = False End Function Private Function IsString(v As Variant) As Boolean IsString = (VarType(v) = vbString) End Function Private Function IsBoolean(v As Variant) As Boolean IsBoolean = (VarType(v) = vbBoolean) End Function Private Function IsObject(v As Variant) As Boolean IsObject = (VarType(v) >= vbObject) End Function Public Function ShouldShowControl(Optional TargetTime As Date = #3:00:00 PM#) As Boolean ShouldShowControl = (Time() < TargetTime) End Function Public Function SetControlVisibility(frm As Form, ctlName As String, _ Optional TargetTime As Date = #3:00:00 PM#) As ControlVisibility On Error GoTo ErrorHandler If frm Is Nothing Or Len(Trim(ctlName)) = 0 Then LogEvent "النموذج أو اسم العنصر غير صالح في SetControlVisibility", [Error] SetControlVisibility = ErrorState Exit Function End If Dim ctl As Control Set ctl = frm.Controls(ctlName) If ctl Is Nothing Then LogEvent "العنصر '" & ctlName & "' غير موجود في النموذج", [Error] SetControlVisibility = ErrorState Exit Function End If Dim bolVisible As Boolean bolVisible = ShouldShowControl(TargetTime) ctl.visible = bolVisible SetControlVisibility = IIf(bolVisible, visible, Hidden) Exit Function ErrorHandler: LogEvent "خطأ في SetControlVisibility للعنصر '" & ctlName & "': " & Err.Description, [Error] SetControlVisibility = ErrorState End Function ' ========================= ' تنفيذ ذكي للدوال ' ========================= Private Sub ExecuteDynamicMethod(ByVal objTarget As Object, ByVal strMethodName As String, Optional arrArgs As Variant) On Error GoTo HandleError InitializeModule If Len(Trim(strMethodName)) = 0 Then LogEvent "اسم الدالة فارغ في ExecuteDynamicMethod", [Error] Exit Sub End If If dicExecuted.Exists(strMethodName) Then LogEvent "الدالة '" & strMethodName & "' تم تنفيذها مسبقاً", Warning Exit Sub End If If Not objTarget Is Nothing Then If IsMissing(arrArgs) Or IsEmpty(arrArgs) Then CallByName objTarget, strMethodName, VbMethod Else ExecuteWithParams objTarget, strMethodName, arrArgs End If Else If IsMissing(arrArgs) Or IsEmpty(arrArgs) Then Application.Run strMethodName Else ExecuteRunWithParams strMethodName, arrArgs End If End If dicExecuted(strMethodName) = True LogEvent "تم تنفيذ '" & strMethodName & "' بنجاح", Information Exit Sub HandleError: LogEvent "خطأ في تنفيذ '" & strMethodName & "': " & Err.Number & " - " & Err.Description, [Error] End Sub Private Sub ExecuteWithParams(objTarget As Object, strMethodName As String, params As Variant) On Error GoTo HandleError Dim paramCount As Long, i As Long Dim tempParams() As Variant If IsArray(params) Then paramCount = UBound(params) + 1 ReDim tempParams(paramCount - 1) For i = 0 To paramCount - 1 If IsFormName(params(i)) Then Set tempParams(i) = Forms(params(i)) Else tempParams(i) = params(i) End If LogEvent "معامل " & i & " لـ '" & strMethodName & "': " & CStr(tempParams(i)), Information Next Else paramCount = 1 ReDim tempParams(0) tempParams(0) = params LogEvent "معامل 0 لـ '" & strMethodName & "': " & CStr(tempParams(0)), Information End If Select Case paramCount Case 0: CallByName objTarget, strMethodName, VbMethod Case 1: CallByName objTarget, strMethodName, VbMethod, tempParams(0) Case 2: CallByName objTarget, strMethodName, VbMethod, tempParams(0), tempParams(1) Case 3: CallByName objTarget, strMethodName, VbMethod, tempParams(0), tempParams(1), tempParams(2) Case 4: CallByName objTarget, strMethodName, VbMethod, tempParams(0), tempParams(1), tempParams(2), tempParams(3) Case Else LogEvent "عدد المعاملات أكثر من 4 غير مدعوم في CallByName لـ '" & strMethodName & "'", [Error] End Select Exit Sub HandleError: LogEvent "خطأ في ExecuteWithParams لـ '" & strMethodName & "': " & Err.Description, [Error] End Sub Private Sub ExecuteRunWithParams(strMethodName As String, params As Variant) On Error GoTo HandleError Dim paramCount As Long, i As Long Dim tempParams() As Variant If IsArray(params) Then paramCount = UBound(params) + 1 ReDim tempParams(paramCount - 1) For i = 0 To paramCount - 1 If IsFormName(params(i)) Then Set tempParams(i) = Forms(params(i)) Else tempParams(i) = params(i) End If LogEvent "معامل " & i & " لـ '" & strMethodName & "': " & CStr(tempParams(i)), Information Next Else paramCount = 1 ReDim tempParams(0) tempParams(0) = params LogEvent "معامل 0 لـ '" & strMethodName & "': " & CStr(tempParams(0)), Information End If Select Case paramCount Case 0: Application.Run strMethodName Case 1: Application.Run strMethodName, tempParams(0) Case 2: Application.Run strMethodName, tempParams(0), tempParams(1) Case 3: Application.Run strMethodName, tempParams(0), tempParams(1), tempParams(2) Case 4: Application.Run strMethodName, tempParams(0), tempParams(1), tempParams(2), tempParams(3) Case Else LogEvent "عدد المعاملات أكثر من 4 غير مدعوم في Application.Run لـ '" & strMethodName & "'", [Error] End Select Exit Sub HandleError: LogEvent "خطأ في ExecuteRunWithParams لـ '" & strMethodName & "': " & Err.Description, [Error] End Sub ' ========================= ' التحقق من توقيت التنفيذ ' ========================= Private Function IsTimeMatch(ByVal dtmStart As Date, ByVal dtmEnd As Variant, ByVal bolUseRange As Boolean) As Boolean Dim dtmNow As Date: dtmNow = Time() If IsMissing(dtmEnd) Or IsNull(dtmEnd) Or Not bolUseRange Then IsTimeMatch = (dtmNow >= dtmStart) Else IsTimeMatch = (dtmNow >= dtmStart And dtmNow <= dtmEnd) End If End Function ' ========================= ' تنفيذ الإجراءات المؤقتة ' ========================= Public Sub CallTimeAction(ByVal objTarget As Object, ByVal strMethodName As String, _ ByVal dtmStart As Date, Optional ByVal dtmEnd As Variant, _ Optional ByVal bolUseRange As Boolean = True) On Error Resume Next If IsTimeMatch(dtmStart, dtmEnd, bolUseRange) Then ExecuteDynamicMethod objTarget, strMethodName End If End Sub Public Sub CallTimeActionWithArgs(ByVal objTarget As Object, ByVal strMethodName As String, _ ByVal arrArgs As Variant, ByVal dtmStart As Date, _ Optional ByVal dtmEnd As Variant, _ Optional ByVal bolUseRange As Boolean = True) On Error Resume Next If IsTimeMatch(dtmStart, dtmEnd, bolUseRange) Then ExecuteDynamicMethod objTarget, strMethodName, arrArgs End If End Sub Public Sub ApplyTimeActions(ByVal objTarget As Object, ByVal arrActions As Variant) InitializeModule Dim arrItem As Variant For Each arrItem In arrActions If Not IsArray(arrItem) Then LogEvent "العنصر في arrActions ليس مصفوفة صالحة", [Error] GoTo ContinueLoop End If Dim strMethod As String: strMethod = arrItem(0) Dim lngUB As Long: lngUB = UBound(arrItem) Dim arrArgs As Variant: arrArgs = Empty Dim dtmStart As Date Dim dtmEnd As Variant: dtmEnd = Null Dim bolUseRange As Boolean: bolUseRange = True If lngUB < 1 Then LogEvent "بيانات غير كافية للإجراء '" & strMethod & "'", [Error] GoTo ContinueLoop End If If IsArray(arrItem(1)) Then arrArgs = arrItem(1) dtmStart = arrItem(2) If lngUB >= 3 Then dtmEnd = arrItem(3) If lngUB >= 4 Then bolUseRange = arrItem(4) ' فحص المعاملات If strMethod = "HideControlByName" And UBound(arrArgs) >= 0 Then If Not IsString(arrArgs(0)) Then LogEvent "معامل HideControlByName ليس سلسلة نصية: " & CStr(arrArgs(0)), [Error] GoTo ContinueLoop End If ElseIf strMethod = "ComplexMsgBox" And UBound(arrArgs) >= 2 Then If Not IsString(arrArgs(0)) Or Not IsBoolean(arrArgs(1)) Or Not IsObject(arrArgs(2)) Then LogEvent "معاملات ComplexMsgBox غير صالحة: " & Join(arrArgs, ","), [Error] GoTo ContinueLoop End If ElseIf strMethod = "LocalMsg" And UBound(arrArgs) >= 1 Then If Not IsString(arrArgs(0)) Or Not IsString(arrArgs(1)) Then LogEvent "معاملات LocalMsg غير صالحة: " & Join(arrArgs, ","), [Error] GoTo ContinueLoop End If End If CallTimeActionWithArgs objTarget, strMethod, arrArgs, dtmStart, dtmEnd, bolUseRange Else dtmStart = arrItem(1) If lngUB >= 2 Then dtmEnd = arrItem(2) If lngUB >= 3 Then bolUseRange = arrItem(3) CallTimeAction objTarget, strMethod, dtmStart, dtmEnd, bolUseRange End If ContinueLoop: Next End Sub ' ========================= ' مثال استخدام ComplexMsgBox ' ========================= Public Sub ComplexMsgBox(ByVal strVal As String, ByVal bolFlag As Boolean, ByVal frm As Form) If bolFlag Then MsgBox "تم تنفيذ الإجراء على النموذج: " & frm.Name & " باستخدام القيمة: " & strVal End If End Sub -------------------------- الوحده النمطية الثانية : bas02:TimeExecutionKeyed المميزات تنفيذ ذكي مشروط بالوقت باستخدام TimedRunWithKey منع التكرار التام بفضل المفتاح الفريد (ExecutionKey) تعامل مرن مع الإجراءات بحد أقصى 4 معاملات بناء مفتاح فريد يجمع اسم الدالة والمعاملات والتوقيت الهدف : تنفيذ إجراءات مشروطة بالوقت وعدم تكرارها أبدا إذا تكررت المدخلات الاستخدام الأمثل : عندما تريد تنفيذ سيناريوهات متعددة و تحتاج لمنع تكرار تنفيذ نفس الإجراء بنفس المعلمات تماما استخدم الكود فى الحالات الآتيـــة : إذا كنت تريد ضمان عدم تكرار نفس الإجراء بنفس الظروف بشكل صارم (مثل تسجيل حركة مرة واحدة فقط لكل توقيت) إذا كنت تحتاج تتبع وتنفيذ ذكي مبني على مفتاح فريد Option Compare Database Option Explicit Private dicExecuted As Object ' ========== التهيئة ========== Private Sub InitializeModule() If dicExecuted Is Nothing Then Set dicExecuted = CreateObject("Scripting.Dictionary") dicExecuted.CompareMode = vbTextCompare End If End Sub Public Sub ResetExecutedLog() If Not dicExecuted Is Nothing Then dicExecuted.RemoveAll End Sub ' ========== أدوات مساعدة ========== Private Function ToSafeString(val As Variant) As String If IsObject(val) Then On Error Resume Next ToSafeString = TypeName(val) Exit Function End If If IsNull(val) Then ToSafeString = "<NULL>" Else ToSafeString = CStr(val) End If End Function Private Function BuildExecutionKey(ByVal strMethod As String, ByVal arrArgs As Variant, _ ByVal dtmStart As Date, ByVal dtmEnd As Variant) As String Dim arrParts() As String Dim i As Long ReDim arrParts(0) arrParts(0) = strMethod If IsArray(arrArgs) Then For i = 0 To UBound(arrArgs) ReDim Preserve arrParts(UBound(arrParts) + 1) arrParts(UBound(arrParts)) = ToSafeString(arrArgs(i)) Next ElseIf Not IsMissing(arrArgs) Then ReDim Preserve arrParts(UBound(arrParts) + 1) arrParts(UBound(arrParts)) = ToSafeString(arrArgs) End If ReDim Preserve arrParts(UBound(arrParts) + 1) arrParts(UBound(arrParts)) = Format(dtmStart, "hh:nn:ss") If Not IsMissing(dtmEnd) And Not IsNull(dtmEnd) Then ReDim Preserve arrParts(UBound(arrParts) + 1) arrParts(UBound(arrParts)) = Format(dtmEnd, "hh:nn:ss") End If BuildExecutionKey = Join(arrParts, "|") End Function Private Function AlreadyExecuted(strExecKey As String) As Boolean AlreadyExecuted = dicExecuted.Exists(strExecKey) End Function Private Sub MarkExecuted(strExecKey As String) dicExecuted(strExecKey) = True End Sub Private Sub Log(ByVal msg As String, Optional msgType As String = "INFO") If DebugMode Then Debug.Print Format(Now, "yyyy-mm-dd hh:nn:ss") & " [TimedActionKey] " & msgType & ": " & msg End Sub Private Function IsTimeMatch(ByVal dtmStart As Date, ByVal dtmEnd As Variant, ByVal bolUseRange As Boolean) As Boolean Dim dtmNow As Date: dtmNow = Time() If IsMissing(dtmEnd) Or IsNull(dtmEnd) Or Not bolUseRange Then IsTimeMatch = (dtmNow >= dtmStart) Else IsTimeMatch = (dtmNow >= dtmStart And dtmNow <= dtmEnd) End If End Function Private Sub RunWithArgs(ByVal objTarget As Object, ByVal strMethod As String, arrArgs As Variant) On Error GoTo HandleError If objTarget Is Nothing Then Select Case UBound(arrArgs) Case 0: Application.Run strMethod, arrArgs(0) Case 1: Application.Run strMethod, arrArgs(0), arrArgs(1) Case 2: Application.Run strMethod, arrArgs(0), arrArgs(1), arrArgs(2) Case 3: Application.Run strMethod, arrArgs(0), arrArgs(1), arrArgs(2), arrArgs(3) Case Else: Log "أكثر من 4 معاملات غير مدعومة لـ " & strMethod, "ERR" End Select Else Select Case UBound(arrArgs) Case 0: CallByName objTarget, strMethod, VbMethod, arrArgs(0) Case 1: CallByName objTarget, strMethod, VbMethod, arrArgs(0), arrArgs(1) Case 2: CallByName objTarget, strMethod, VbMethod, arrArgs(0), arrArgs(1), arrArgs(2) Case 3: CallByName objTarget, strMethod, VbMethod, arrArgs(0), arrArgs(1), arrArgs(2), arrArgs(3) Case Else: Log "أكثر من 4 معاملات غير مدعومة لـ " & strMethod, "ERR" End Select End If Exit Sub HandleError: Log "خطأ في تنفيذ " & strMethod & ": " & Err.Number & " - " & Err.Description, "ERR" End Sub ' ========== الدالة الرئيسية ========== Public Sub TimedRunWithKey(ByVal objTarget As Object, ByVal strMethod As String, _ ByVal arrArgs As Variant, ByVal dtmStart As Date, _ Optional ByVal dtmEnd As Variant, _ Optional ByVal bolUseRange As Boolean = True) InitializeModule If Not IsTimeMatch(dtmStart, dtmEnd, bolUseRange) Then Exit Sub Dim strKey As String strKey = BuildExecutionKey(strMethod, arrArgs, dtmStart, dtmEnd) If AlreadyExecuted(strKey) Then Log "تخطي التنفيذ المكرر لـ " & strMethod, "WARN" Exit Sub End If RunWithArgs objTarget, strMethod, arrArgs MarkExecuted strKey Log "تم التنفيذ بـ Key: " & strKey End Sub ' For Tesr Public Sub TestMsgProc(ByVal strMsg As String, ByVal bolShow As Boolean) If bolShow Then MsgBox "تم التنفيذ: " & strMsg, vbInformation, "اختبار" Else Debug.Print "? تم تجاهل الإظهار ولكن التنفيذ تم: " & strMsg End If End Sub وأخيرا المرفق TimedAction.accdb

جربت ارقام جديدة ولكن توجد مشكلة ارقام مفقودة.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته الطريقة 1 : ضع المعادلة مثلا في B2 واسحب للأسفل: =IF(COUNTIF(A:A, ROW())=0, ROW(), "") الطريقة 2 : ضع المعادلة التالية مع استبدال الرقم 100 حسب الحد الأقصى في بياناتك ثم اسحب للأسفل: =IFERROR(SMALL(IF(COUNTIF(A:A,ROW(INDIRECT("1:100")))=0,ROW(INDIRECT("1:100"))),ROWS(B$1:B1)),"") أو بشكل ديناميكي =IFERROR(SMALL(IF(ISNA(MATCH(ROW(INDIRECT("1:" & MAX(A:A))), A:A, 0)), ROW(INDIRECT("1:" & MAX(A:A)))), ROWS(B$2:B2)), "") ادا كنت تستخدم نسخة حديثة من الأوفيس =LET( maxVal, MAX(A:A),fullSet, SEQUENCE(maxVal),missing, FILTER(fullSet, ISNA(MATCH(fullSet, A:A, 0))), IF(ROWS(B$2:B2)<=ROWS(missing), INDEX(missing, ROWS(B$2:B2)), "")) او بإستخدام الأكواد : يمكنك تعديل Max لتحديد الحد الأقصى الذي تبحث فيه عن الأرقام Option Explicit Sub RechercherNum() Dim lastRow As Long, i As Long, Max As Long Dim dict As Object, tmp As Long, col As String, a As Variant Dim WS As Worksheet: Set WS = Sheets("ورقة1") Set dict = CreateObject("Scripting.Dictionary") col = "G" ' عمود وضع القيم المفقودة Max = 100 ' الحد الأقصى المتوقع With Application .ScreenUpdating = False: .Calculation = xlCalculationManual: .EnableEvents = False WS.Range(col & "2:" & col & WS.Rows.Count).ClearContents lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row For i = 1 To lastRow a = WS.Cells(i, 1).Value If IsNumeric(a) Then dict(CLng(a)) = True Next i tmp = 2 For i = 1 To Max If Not dict.exists(i) Then WS.Cells(tmp, col).Value = i tmp = tmp + 1 End If Next i .ScreenUpdating = True: .Calculation = xlCalculationAutomatic: .EnableEvents = True End With End Sub ارقام مفقودة.xlsb

نكش ينكش نكشا دى النتيجه

حبيبي زياد ربي يسعدك .. شكراً لك على تهنئتك

مبارك اخي فادي تستاهل كل خير و بجدارة

السلام عليكم ملف اكسل يحتوي على مجموعة من الارقام المتسلسلة لكن توجد ارقام مفقودة هل يمكن التعرف على الارقام الغير موجودة ؟؟؟ ارقام مفقودة.xlsx

هههه ، انا لو كنت عاوز أفتح الباب للفضول أكتر ، كان اقترحت الفكرة دي مثلاً :- Private Sub Form_Load() On Error Resume Next Me.Alborg.Visible = (Time() <= #3:00:00 PM#) On Error GoTo 0 End Sub أما لو عاوز نفتحها بحري ونتوسع في الحديث ، فممكن نعمل الآتي :- في مديول لوحده كده بدون ما حد يزعجه :- Option Compare Database Option Explicit Public Enum ControlVisibility visible = 0 Hidden = 1 ErrorState = 2 End Enum Public Enum EventType Information = 0 Warning = 1 [Error] = 2 End Enum Public Function ShouldShowControl(Optional targetTime As Date = #3:00:00 PM#) As Boolean ShouldShowControl = (Time() < targetTime) End Function Public Function SetControlVisibility(frm As Form, ctlName As String, _ Optional targetTime As Date = #3:00:00 PM#) As ControlVisibility On Error GoTo ErrorHandler Dim ctl As Control Set ctl = frm.Controls(ctlName) If ctl Is Nothing Then SetControlVisibility = ErrorState Exit Function End If Dim visible As Boolean visible = ShouldShowControl(targetTime) ctl.visible = visible SetControlVisibility = IIf(visible, visible, Hidden) Exit Function ErrorHandler: LogEvent "Error setting visibility for " & ctlName, EventType.Error SetControlVisibility = ErrorState End Function Public Sub LogEvent(message As String, Optional msgType As EventType = EventType.Information) #If DEBUG_MODE Then Debug.Print Format(Now, "yyyy-mm-dd hh:mm:ss") & " [TimeBasedControl] " & _ Choose(msgType + 1, "INFO", "WARN", "ERR") & ": " & message #End If End Sub طبعاً هنقدر نستدعي الفكرة دي بشكل متعدد لأكثر من وقت وأكتر من هدف 😋 :- 1️⃣ الطريقة البسيطة الأولى :- Private Sub Form_Load() UpdateControlVisibility #7:00:00 PM# End Sub Private Sub Form_Timer() Static lastUpdate As Date If Now > lastUpdate + TimeSerial(0, 0, 30) Then UpdateControlVisibility #7:00:00 PM# 'هنا طبعاً الوقت اللي عايزه lastUpdate = Now End If End Sub Private Sub UpdateControlVisibility(targetTime As Date) Dim result As ControlVisibility result = SetControlVisibility(Me, "SendBtn1", targetTime) 'باللي انت عايزه SendBtn1 بدل اسم الزر If result = ErrorState Then MsgBox "فشل تحديث العنصر", vbExclamation + vbMsgBoxRight, "" End If End Sub 2️⃣ الطريقة الثانية :- Private mTargetTime As Date Private Sub Form_Load() mTargetTime = #8:45:00 PM# UpdateTimeDisplay UpdateControlVisibility End Sub Private Sub cmdSetTime_Click() Dim newTime As String newTime = InputBox("أدخل الوقت المطلوب (HH:MM:SS AM/PM)", "تعيين الوقت", Format(mTargetTime, "hh:mm:ss AM/PM")) If newTime <> "" Then If IsDate(newTime) Then mTargetTime = CDate(newTime) UpdateTimeDisplay UpdateControlVisibility Else MsgBox "تنسيق الوقت غير صالح", vbExclamation + vbMsgBoxRight, "خطأ" End If End If End Sub Private Sub UpdateTimeDisplay() lblCurrentTime.Caption = "الوقت الحالي: " & Format(Time, "hh:mm:ss AM/PM") & vbCrLf & _ "الوقت المستهدف: " & Format(mTargetTime, "hh:mm:ss AM/PM") End Sub Private Sub Form_Timer() Static lastUpdate As Date If Now > lastUpdate + TimeSerial(0, 0, 1) Then btnEvening.SetFocus UpdateTimeDisplay UpdateControlVisibility lastUpdate = Now End If End Sub Private Sub UpdateControlVisibility() Dim result As ControlVisibility result = SetControlVisibility(Me, "SendBtn1", mTargetTime) If result = ErrorState Then LogEvent "فشل تحديث عنصر التحكم", EventType.Error End If End Sub 3️⃣ الطريقة الثالثة ، وسأكتفي بدون ما نتوسع أكتر من كده 😅 :- Private Type ControlTimeSettings ControlName As String ShowBeforeTime As Date ShowAfterTime As Date End Type Private mControlSettings() As ControlTimeSettings Private Sub Form_Load() ReDim mControlSettings(2) With mControlSettings(0) .ControlName = "btnMorning" .ShowBeforeTime = #12:00:00 PM# .ShowAfterTime = #12:00:00 AM# End With With mControlSettings(1) .ControlName = "btnAfternoon" .ShowBeforeTime = #6:00:00 PM# .ShowAfterTime = #12:00:00 PM# End With With mControlSettings(2) .ControlName = "btnEvening" .ShowBeforeTime = #11:59:59 PM# .ShowAfterTime = #6:00:00 PM# End With UpdateControlsVisibility End Sub Private Sub Form_Timer() Static lastUpdate As Date If Now > lastUpdate + TimeSerial(0, 0, 30) Then UpdateControlsVisibility lastUpdate = Now End If End Sub Private Sub UpdateControlsVisibility() Dim i As Integer Dim currentTime As Date Dim shouldBeVisible As Boolean Dim result As ControlVisibility currentTime = Time() For i = LBound(mControlSettings) To UBound(mControlSettings) With mControlSettings(i) If .ShowAfterTime < .ShowBeforeTime Then shouldBeVisible = (currentTime >= .ShowAfterTime And currentTime < .ShowBeforeTime) Else shouldBeVisible = (currentTime >= .ShowAfterTime Or currentTime < .ShowBeforeTime) End If result = SetControlVisibility(Me, .ControlName, IIf(shouldBeVisible, #12:00:00 AM#, #11:59:59 PM#)) If result = ErrorState Then LogEvent "فشل تحديث عنصر التحكم: " & .ControlName, EventType.Error End If End With Next i End Sub Control Visibility.accdb

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

من باب النكاش مع اخى الحبيب @Foksh انا مبحبش اجاوب ع القد بالظبط لازم احط التاتش بتاعى ده كود ديناميكى علشان لو النموذج كان مفتوح اساسا قبل الوقت وطبعا لانى معقد باعمل حساب اى اخطاء وطبعا علشان موضوع ديناميكى ده يشتغل لازم ولابد وحتما : TimerInterval > 0 ' اسم التحكم المطلوب تغيير حالته Private Const strControlName As String = "Alborg" ' تفعيل الطباعة في نافذة Immediate لتتبع التنفيذ (يفضل تعريفه في وحدة عامة ) Public DebugMode As Boolean ' دالة تقوم بإرجاع الوقت الهدف بتنسيق موحد باستخدام TimeSerial Private Function GetTargetTime() As Date GetTargetTime = TimeSerial(15, 0, 0) ' الساعة 3:00:00 مساءً End Function ' التحقق مما إذا كان التحكم موجودًا في النموذج لتفادي الأخطاء Private Function ControlExists(ByVal strCtlName As String) As Boolean On Error Resume Next ControlExists = Not Me.Controls(strCtlName) Is Nothing On Error GoTo 0 End Function ' تحديث خاصية الظهور للتحكم حسب الوقت الحالي Private Sub UpdateControlVisibility() On Error GoTo Update_Error ' التأكد من وجود التحكم أولًا If ControlExists(strControlName) Then Dim bolShouldShow As Boolean bolShouldShow = (Time() <= GetTargetTime()) ' تغيير خاصية الظهور بناءً على الوقت Me.Controls(strControlName).Visible = bolShouldShow ' طباعة الحالة في نافذة Immediate إذا كان DebugMode مفعّل If DebugMode Then Debug.Print "Visibility of control '" & strControlName & "' set to: " & bolShouldShow & " at " & Now End If Else MsgBox "Control '" & strControlName & "' not found on the form.", vbExclamation, "Missing Control" End If Exit Sub Update_Error: MsgBox "An error occurred in UpdateControlVisibility: " & Err.Description, vbCritical, "Error" End Sub ' يتم استدعاء هذا الحدث عند تحميل النموذج لأول مرة Private Sub Form_Load() On Error GoTo Load_Error ' DebugMode = True ' تحديث حالة ظهور التحكم عند فتح النموذج UpdateControlVisibility Exit Sub Load_Error: MsgBox "An error occurred in Form_Load: " & Err.Description, vbCritical, "Error" End Sub ' يتم استدعاء هذا الحدث بشكل دوري إذا تم تفعيل Timer للنموذج Private Sub Form_Timer() ' تحديث حالة الظهور ديناميكيًا كل فترة UpdateControlVisibility End Sub

تفتح العديد من ابوب النكاش

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

يا هلا والله ... والله اشتقنا مبارك مبارك مبارك لنا نحن انضمامكم الينا

مبارك عليك أخي @Ahmos 🙂 أنت أهل لها إن شاء الله ومبارك علينا انظمامك لهذه الأسرة الفاضلة المباركة .. 🌹 جعلك الله عطائك لا ينضب 🙂🤲

الترقية وسام شرف أضعه على صدري ، وكلماتكم زادتني سعادة وحرصاً على تقديم الأفضل دائماً . تقديري واحترامي لشخصكم الكريم و لكل من مرّ وبارك

اخي فادي اهلا وسهلا بك ضمن فريق العمل ، وما ذلك عليك بغريب ، فقد كنت تمارس هذا الدور بدون اللقب 🙂 جعفر

بارك الله فيك هو دا المطلوب

وعليكم السلام ورحمة الله وبركاته .. جرب هذا التعديل أخي الكريم رصيد بنــــك الكويت.xlsx

جرب هذا التعديل أخي الكريم :- Sub Observer222() Dim ws As Worksheet Dim lastRowObservers As Long, lastRowCommittees As Long, lastCol As Long Dim maxObserversPerCommittee As Integer, attempts As Integer Dim row As Long, col As Long, observerRow As Long Dim observerID As Variant, isValid As Boolean Dim startTime As Double, retryCount As Integer Const maxAttempts As Integer = 200 Const password As String = "0" Const sheetName As String = "Sheet1" On Error GoTo ErrorHandler If Application.InputBox("أدخل كلمة المرور", "تسجيل الدخول") <> password Then MsgBox "كلمة المرور غير صحيحة", vbExclamation, "خطأ" Exit Sub End If startTime = Timer Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set ws = ThisWorkbook.Worksheets(sheetName) ws.Unprotect password lastRowObservers = ws.Cells(ws.Rows.Count, 2).End(xlUp).row lastRowCommittees = ws.Cells(ws.Rows.Count, 3).End(xlUp).row lastCol = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column If lastCol >= 4 Then ws.Range(ws.Cells(3, 4), ws.Cells(lastRowCommittees, lastCol)).ClearContents End If For retryCount = 1 To 3 Dim emptyCells As Integer emptyCells = 0 For row = 3 To lastRowCommittees For col = 4 To lastCol If ws.Cells(row, col).Value = "" Then attempts = 0 isValid = False Do While attempts < maxAttempts And Not isValid attempts = attempts + 1 observerRow = Application.RandBetween(3, lastRowObservers) observerID = ws.Cells(observerRow, 2).Value If Not IsEmpty(observerID) Then If Application.CountIf(ws.Range(ws.Cells(row, 4), ws.Cells(row, col - 1)), observerID) = 0 And _ Application.CountIf(ws.Range(ws.Cells(3, col), ws.Cells(row - 1, col)), observerID) = 0 Then isValid = True End If End If Loop If isValid Then ws.Cells(row, col).Value = observerID Else emptyCells = emptyCells + 1 End If End If Next col Next row If emptyCells = 0 Then Exit For Next retryCount For row = 3 To lastRowCommittees For col = 4 To lastCol If ws.Cells(row, col).Value = "" Then For observerRow = 3 To lastRowObservers observerID = ws.Cells(observerRow, 2).Value If Not IsEmpty(observerID) Then If Application.CountIf(ws.Range(ws.Cells(row, 4), ws.Cells(row, col - 1)), observerID) = 0 Then ws.Cells(row, col).Value = observerID Exit For End If End If Next observerRow End If Next col Next row CleanExit: Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True ws.Protect password Dim emptyCount As Integer emptyCount = Application.CountBlank(ws.Range(ws.Cells(3, 4), ws.Cells(lastRowCommittees, lastCol))) If emptyCount > 0 Then MsgBox "تم التوزيع مع وجود " & emptyCount & " قيم فارغة بسبب عدم توفر ملاحظين متاحين", vbExclamation + vbMsgBoxRight, "تنبيه" Else MsgBox "تم التوزيع بنجاح", vbInformation + vbMsgBoxRight, "تم" End If Exit Sub ErrorHandler: MsgBox " : حدث خطأ" & Err.Description, vbCritical + vbMsgBoxRight, "خطأ" Resume CleanExit End Sub

الملف المرسل في مشاركة سابقة ممتاز و يعمل بكفاءة و يوزع عدد 2 ملاحظين في كل لجنة برجاء تجربتة و كتابة ملاحظاتك. قمت بتعديل عدد اللجان و الملاحظين ليتوافق مع اللجان عندك توزيع الملاحظين .xlsm

@kanory بارك الله فيك شكراً جزيلاً

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

ولا يهمك أخي الكريم .. طيب جرب هذه الدالة ، وتستطيع وضعها في مديول عام اذا أردت .. Public Sub UpdateBooksToLost() Dim db As DAO.Database Dim rs As DAO.Recordset Dim maxGard As Long Set db = CurrentDb maxGard = Nz(DMax("No_Gard", "T_Gard"), 0) Set rs = db.OpenRecordset("SELECT * FROM [جدول تسجيل الكتب] WHERE [CaseBook] = 'موجود'", dbOpenDynaset) If Not rs.EOF Then rs.MoveFirst Do While Not rs.EOF rs.Edit rs!CaseBook = "فاقد" rs![G N] = maxGard rs.Update rs.MoveNext Loop End If rs.Close Set rs = Nothing Set db = Nothing MsgBox "تم تحديث الكتب إلى الحالة 'فاقد' وتعيين رقم الجرد بنجاح", vbInformation + vbMsgBoxRight, "" End Sub واستدعيها في أي زر من خلال UpdateBooksToLost فقط .

المقصود ان لكل ملاحظ مسلسل يتم التوزيع من خلال مسلسلة لتسهيل التوزيع بدلا من الاسماء في العمود A والعمود B يمثل ارقام اللجان