كل الانشطه

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

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

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

الف . الف . مبروك @Ahmos تستاهل ... ومزيد من الابداع

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

الف . الف . مبرك اخي @Foksh يستاهل من ضحى بوقته وجهده وعلمه للاعضاء ... مزيد من التألق

الف مبروك اخي العزيز فادي .. وأهلا بك بين اخوانك

الف مبروك🌻 واهلا بك أخي فادي في فريق الموقع

السلام عليكم ورحمة الله وبركاته 🌹 بكل فخر وسعادة، تتقدم إدارة منتديات أوفيسنا وكافة أعضائها الكرام بأحرّ التهاني والتبريكات للأخ العزيز فادي @Foksh بمناسبة ترقيته إلى درجة مشرف 👏🎖️ لقد أثبت حضورك وجهودك الملحوظة في دعم الأعضاء وتقديم الفائدة باستمرار، وكان لعطائك بصمة واضحة في رُقي المنتدى وتطوره 📈💡 ✨ نبارك لك هذه الترقية المستحقة، ونتمنى لك كل التوفيق والنجاح في مهامك الجديدة ضمن كوكبة الإشراف في فريق الموقع 🌟 🌟 أهلاً وسهلاً بك في فريق أوفيسنا، واثقين بأنك ستواصل تميزك وتألقك بإذن الله 🌈 مع أطيب التحيات والتقدير، إدارة منتديات أوفيسنا 💼🌟

ما المقصود بعدد الملاحظين حيث الأرقام في العمود متسلسلة؟ هل عدد اللجان المقصود منه رقم اللجنة أم إجمالي اللجان التي سيتم توزيع الملاحظين عليه. كلما كانت المعطيات واضحة كلما كانت النتائج أفض.

الف ميروك 💐