نجوم المشاركات

السلام عليكم أسوق لكم تجربتي الطازجة : انا استخدم وندوز 10 قبل يومين وعند اقلاع الحاسوب اظهر على الشاشة ( الجحش وندوز ) واعذروني على الوصف .. أظهر على الشاشة امامي انه سوف يقوم بالتحديث لم يعطني خيارا للرفض .. لا يوجد الا زر واحد للمتابعة قلت ماشي يمكن يريد يحدث ملفات النظام لوجود خلل بها الجحش ركب لي وندوز 11 تصفحته .. حلو .. الوان جميلة .. وتبويبات لها اول وليس لها آخر في وندز 10 كان كل شيء بجانبي وسهل الوصول اليه .. اما هذا فيحتاج الى خطوات وقوائم واحدة خلف الأخرى من اجل اصل الى الخصيصة المطلوبة صحيح انه مطور لخاصية اللمس ، ولكني رجل عجوز .. اعتدت على كل شيء قريب مني اسلمت أمري الى الله .. وقلت اتعايش معه واصبر واتحمل حتى اعتاد عليه .. لن أكون اضعف ممن اخذ على ام اولاده ، فتاة عروسا وروضها للعلم الملف الذي يتم تحزيمه accde على 11 لا يعمل على 10 ولكنه اليوم ركز رأسه في الجدار وقال لي : ربي وربك واحد لن اجعلك تهتني في عروسك الجديدة بدأت الملفات تومض وترتعش كأن بها حمى ولم اتمكن من فتحها . اتصلت بأهل العلم والخبرة فأفادوني ان كل هذه الافاعيل من برنامج الحماية المدرج ضمن وندوز وأشاروا علي بالتراجع .. الى الاصدار السابق .. حيث يوجد ايقونة في النظام خاصة بهذا الشان تسمح بالاستعادة الحمد لله طبقت النصيحة ورجعت الى دياري سالما .

اعرض الملف برنامج العطاء للعقارات الاصدار 3.7 برنامج العطاء للعقارات الاصدار 3.7 يتم تسجيل بيانات ملاك العقارات اولا ثم تسجيل عقود المستاجرين وتاريخ بداية الايجار وعمل توزيع لها ظهور الايجارات المستحقة في تقرير حسب تاريخ استحقاق الايجار - تقرير للمستاجر لبيان عدد مرات الايجار وغيرها - تقرير يظهر الشقق الغير مؤجرة - تقرير يظهر شقق وعقارات باسم الحي - تقرير يظهر شقق المالك والباقي تقدر تكتشفة بالبرنامج البرنامج يتم استعمالة في الايجارات للشقق والاراضي وغيرها لمن يعملون في مكاتب العقار صاحب الملف waleed907 تمت الاضافه 06/21/25 الاقسام قسم الأكسيس

الوحده النمطية الأولى: 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

ببساطة أخي @زياد الحسناوي بعد إضافة الأرقام الجديدة لم تقم بسحب المعادلات للأسفل كما تمت الإشارة إليه في المشاركة السابقة وذلك لأنني قمت بوضع المعادلة على الملف المرفق بقدر البيانات الموجودة سابقا فقط هناك كدالك نقطة مهمة يجب الإنتباه إليها في المعادلة المقترحة =IFERROR(SMALL(IF(ISNA(MATCH(ROW(INDIRECT("1:" & MAX(A:A))), A:A, 0)), ROW(INDIRECT("1:" & MAX(A:A)))), ROWS(D$2:D2)), "") وظيفتها إظهار الأرقام المفقودة من تسلسل يبدأ من 1 حتى أكبر رقم موجود في العمود A وتعرض النتيجة في العمود D أو B حسب وضعها كما جاء في طلبك لكن هذه الصيغة تفترض أن الأرقام تبدأ من 1 وتتزايد بواحد مثال عندما تكون الأرقام بهذا الشكل مثلا فالصيغة أعلاه لن تعمل كما يجب لأنها تبدأ بالبحث من الرقم 1 بينما الأرقام الفعلية تبدأ من 15 لحل هذا الإشكال نقترح استخدام الصيغة التالية التي تعتمد على أصغر وأكبر رقم موجودين فعليا في العمود A =IFERROR(SMALL(IF(ISNA(MATCH(ROW(INDIRECT("1:" & MAX(A:A))), A:A, 0)), ROW(INDIRECT("1:" & MAX(A:A))) ), ROWS(D$2:D2)), "") المعادلة تبحث عن جميع الأرقام بين MIN و MAX وتستبعد الأرقام الموجودة فعليا في العمود A أي ترجع فقط الأرقام المفقودة في تسلسل منتظم وتعرض النتائج بشكل ديناميكي في العمود D بدءا من D2 ارقام مفقودة 3.xlsb

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

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

🤗 بارك الله بكم أستاذنا الكبير ، وأشكر لكم ثقتكم .. وما نحن إلا سائرون على خطاكم ونهجكم .

أسمحوا لي أن أخالفكم الرأي وأبارك للمنتدى وأعضاؤه بإنضمام الرائع @Foksh إلى فريق الموقع

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

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

بدايةً ، حمد لله على سلامتكم .. فعلاً كانت لي تجربة مع ويندوز 11 حيث تشجعت وبكامل إرادتي قمت بعمل فورمات للويندوز 10 السابق وبتنصيب ويندوز 11 بتحديثات شهر 1/2025 ، وبالفعل .. تم التثبيت وتثبيت التعريفات التي لم يتمكن من تعريفها ، وتثبيت وتنصيب برامجي الخاصة قبل أي برامج أخرى مثل الأوفيس والفوتوشوب .... وغيرها من مستلزماتي طبعاً هذا الحديث كان تقريباً الساعة 1 بعد منتصف الليل ، وما أن كان أذان الفجر قد اقترب حتى كنت عائداً الى الويندوز 10 ... طبعاً السبب كان هو بعض المشاكل التي ظهرت في اوفيس 2016 وخصوصاً آكسيس وتحديداً بعد خصائص الكومبوبوكس في بعض المشاريع أصبحت لا تعمل .. فتجاهلت التحديث طبعاً وعدت دياري كما فعلتم فعلاً يا أخي حسيت حالي غريب

ماشاءالله عمل رائع وجميل بارك الله فيك اخي فادي

الف الف مبروك أخي الفاضل فادي تستاهل وبجدارة اللقب على ما تقدمه دائما لهذا الصرح الكبير تحياتي لك

وبما أنني أرجح فكرة معلمي الفاضل @ابوخليل !! لهذا السبب هو كل ما عليك فعله استخدام الكود التالي في جزء التفاصيل في حدث عند التنسيق :- Static prevDate As Variant If Me.exDate = prevDate Then Me.تسمية50.Visible = False Me.تسمية55.Visible = False Else Me.تسمية50.Visible = True Me.تسمية55.Visible = True prevDate = Me.exDate End If وستكون النتيجة بهذا الشكل :- 💥 أيضاً تستطيع تنفيذ نفس الفكرة السابقة ، بدون أي أكواد ، من خلال :- تحديد مربعات النص التي لا تريد أن لا يتم عرضها مكررة . الذهاب الى التبويب Format = تنسيق . تفعيل لمنع التكرار من الظهور .

السلام عليكم الف مبروك للاخ فادي بالترقية الى درجة مشرف في منتديات اوفيسنا . اعمالك دائما مميزة

مشاركة مع اخي @Foksh تم التصرف بكثير من التنسيق والتسميات مثلا تسمية الكائنات الأفضل ان تكون اسماؤها تدل على محتواها Data126.rar

وعليكم السلام ورحمة الله وبركاته 🤗.. جرب هذا التعديل أخي الكريم :- Private Sub Workbook_Open() Dim filePath As String ' المسار الكامل للملف filePath = "C:\Program Files\new\officeteam.txt" ' تحقق من وجود الملف If Dir(filePath) = "" Then MsgBox "ليس لديك الاذن في الاستخدام, يرجى التواصل مع مالك النظام . تنبيه.", vbCritical ThisWorkbook.Close SaveChanges:=False End If End Sub المشكلة أن الكود الذي كتبته يحتوي على خطأ في طريقة تحديد المسار ، حيث إنك قمت بدمج filePath مع requiredFile مرتين .

وإياكم أستاذنا الكبير ، ونسأل الله أن نكون عند حسن ظنهم . وأن نتعلم من علمكم الذي وهبكم الله إياه . الله يبارك فيك أخي الحبيب .. نتمنى أن نراكم بجانبنا يوماً ما حبيبي مهندس عمر .. الله يبارك فيك ، ونتمنى لكم المضي بجانبنا

ههههههههه كثروا في النكاش والتناكش فالمستفيد في النهاية (المستهلك ) إللي هوا إحنا طبعاً زادكم الله من فضله وبارك في علمكم

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

من باب النكاش مع اخى الحبيب @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

وعليكم السلام ورحمة الله وبركاته .. جرب هذا التعديل أخي الكريم رصيد بنــــك الكويت.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

السلام عليكم هل الكود المقترح سيحول كلمة (الله) إلى (اللة) ؟ وهل سيجعل (ليلى أو مروى) إلى (ليلي أو مروي) ؟ أو (عبدالهادي) إلى (عبدالهادى) ؟ إذا حصل هذا الأمر فالكود يحتاج لمراجعة الرجاء الانتباه

وعليكم السلام ورحمة الله تعالى وبركاته data.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته Sub Sheets_Arrays3() Dim lr&, LR2&, WSData As Worksheet Dim Dest As Worksheet: Set Dest = Sheets("class_room") LR2 = Dest.Cells(Dest.Rows.Count, "B").End(xlUp).Row If LR2 >= 2 Then Dest.Range("B2:S" & LR2).ClearContents Application.ScreenUpdating = False For Each WSData In Sheets(Array("كي جي1", "كي جي2", _ "الصف الأول", "الصف الثاني", "الصف الثالث", "الصف الرابع", "الصف الخامس", "الصف السادس")) lr = WSData.Cells(WSData.Rows.Count, "B").End(xlUp).Row If lr >= 3 Then LR2 = Dest.Cells(Dest.Rows.Count, "B").End(xlUp).Row + 1 Dest.Range("B" & LR2 & ":S" & (LR2 + lr - 3)).Value = WSData.Range("B3:S" & lr).Value End If Next WSData Application.ScreenUpdating = True MsgBox "تم ترحيل الفرق بنجاح", vbInformation End Sub

وعليكم السلام ورحمة الله تعالى وبركاته هناك عدة حلول تعتمد على طريقة عملك منها استخدام USERPROFILE لجعل مسار الملف ديناميكيا _ وضع المصنف في نفس مجلد ملف الماكرو أو السماح للمستخدم باختيار الملف يدويا (Browse) كما أشار الأخ الفاضل @hegazee اليك الأكواد بالترتيب المدكور يمكنك إختيار ما يناسبك Sub OpenWorkbook1() Dim xPath As String, CrWS As Workbook On Error GoTo ErrHandler xPath = Environ("USERPROFILE") & "\Desktop\aa.xlsb" ' OR <===== aa.xlsx If Dir(xPath) = "" Then MsgBox "الملف غير موجود: " & xPath, vbExclamation: Exit Sub Set CrWS = Workbooks.Open(xPath) MsgBox "تم فتح الملف بنجاح", vbInformation Exit Sub ErrHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Sub '=================================================== Sub OpenWorkbook2() Dim xPath As String, CrWS As Workbook On Error GoTo ErrHandler xPath = ThisWorkbook.Path & "\aa.xlsb" ' OR <===== aa.xlsx If Dir(xPath) = "" Then MsgBox " :الملف غير موجود" & vbNewLine & vbNewLine & xPath, vbExclamation: Exit Sub Set CrWS = Workbooks.Open(xPath) MsgBox "تم فتح الملف بنجاح", vbInformation Exit Sub ErrHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Sub '================================================== Sub OpenWorkbook3() Dim xPath As String, CrWS As Workbook On Error GoTo ErrHandler xPath = Application.GetOpenFilename("إختيار الملف (*.xls*), *.xls*") If xPath = "False" Then MsgBox "تم إلغاء العملية", vbInformation: Exit Sub Set CrWS = Workbooks.Open(xPath) MsgBox "تم فتح الملف بنجاح: " & xPath, vbInformation Exit Sub ErrHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Sub وفي حالة الرغبة في التحقق من أن إسم الملف الذي يختاره المستخدم يطابق إسم معين مثلا aa.xlsb قبل فتح الملف Sub OpenWorkbook4() Dim xPath$, CrWS As Workbook,Sname$ On Error GoTo ErrHandler Sname = "aa.xlsb" xPath = Application.GetOpenFilename("إختيار الملف (*.xls*), *.xls*") If xPath = "False" Then: MsgBox "تم إلغاء العملية", vbInformation: Exit Sub fileName = Dir(xPath) If StrComp(fileName, Sname, vbTextCompare) <> 0 Then MsgBox "اسم الملف غير مطابق" & vbNewLine & Sname, vbCritical Exit Sub End If Set CrWS = Workbooks.Open(xPath) MsgBox " :تم فتح الملف بنجاح" & vbNewLine & vbNewLine & CrWS.name, vbInformation Exit Sub ErrHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Sub bb.xlsb

وعليكم السلام ورحمة الله و بركاته نعم، يمكن تعديل الكود ليعمل على فتح الملف من أي كمبيوتر بشرط أن يتم اختيار الملف يدويًا من خلال نافذة اختيار الملفات (File Dialog)، بدلاً من تحديد مسار ثابت مثل C:\Users\.... إليك أخي الكريم الكود المعدل ليعرض نافذة لاختيار الملف يدويًا: Sub ImportDataFromAnotherExcelFile() Dim FilePath As String Dim wb As Workbook ' فتح نافذة اختيار الملف With Application.FileDialog(msoFileDialogFilePicker) .Title = "اختر ملف Excel" .Filters.Clear .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm" If .Show = -1 Then ' تم اختيار الملف FilePath = .SelectedItems(1) Else MsgBox "لم يتم اختيار أي ملف.", vbExclamation Exit Sub End If End With ' فتح الملف Set wb = Workbooks.Open(FilePath) ' يمكنك الآن استخدام wb كمؤشر للملف المفتوح MsgBox "تم فتح الملف بنجاح: " & wb.Name End Sub bb2.xlsb

أضف هذا السطر: .Replace "عبد ال", "عبدال" ليصبح كامل الكود كالتالي: Dim ch LR = Cells(Rows.Count, 3).End(xlUp).Row With Range("B3:B" & LR) For Each ch In Array("إ", "أ", "آ") .Replace CStr(ch), "ا" Next .Replace "ة", "ه" .Replace "ى", "ي" .Replace "عبد ال", "عبدال" End With أشك أن هذا السطر مقلوب: .Replace "ى", "ي"

قمت باضافة ارقام جديدة ولكن ظهرت مشكلة في الاعمدة ارقام ليست متسلسلة وتوجد خلايا فارغة ارقام مفقودة 2.xlsb