hegazee

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

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

عندما يكون العدد كبير يمكن التحكم في الشروط و لكن الواقع غير ذلك فيكون أهم شرط هو التساوي قدر الأمكان أما دخول نفس اللجان فيتم التحكم فيها يدويا . جرب الملف المرفق بعد تعديل الكود كود (1).xlsm

السلام عليكم ورحمة الله و بركاته المشكلة الرئيسية في هذه الأكواد التي تستخدم في توزيع الملاحظة هي أنها قد تدخل في حلقة لا نهائية عندما لا يمكن إيجاد حل يلبي جميع الشروط. عندما تفرض شروط صارمة على التوزيع (مثل عدم التكرار أو حد التكرار)، فإن هناك احتمالًا أن يفشل الكود في إيجاد توزيع مناسب — مما يؤدي إلى حلقة لا نهائية تقريبا أو وقت تنفيذ طويل جدًا. فمثلا لجنة ثانوية عامة هذا العام بها 45 لجنة مع حوالي 110 ملاحظ لذلك لابد من التغاضي عن بعض الشروط عند كتابة الكود ثم التدخل يدويا في أضيق الحدود. و مشاركتك السابقة عند طلب برنامج ملاحظة قدمت محاولة ممتازة لأحد الأستاذة تفي بالغرض هي كما ذكرت سابقا لابد من التدخل اليدوي. و ننتظر مشاركات اأساتذة المنتدى في هذا الموضوع. جرب الكود التالي فهو على الأقل يضمن عدم التكرار و يتبقى بعض الخلايا البسيطة الغير موزعة فيمكن توزيعها يدوي. Public Sub Observer222() Dim ws As Worksheet Dim row As Long, col As Long Dim lr1 As Long, lr2 As Long, lc1 As Long, max As Long Dim attempt As Long, totalAttempts As Long Dim randVal As Variant Dim isValid As Boolean Dim availableNames As Variant ' تغيير التعريف هنا Dim i As Long ' إعداد الورقة On Error Resume Next Set ws = Worksheets("Sheet1") On Error GoTo 0 If ws Is Nothing Then MsgBox "لم يتم العثور على الورقة 'Sheet1'!", vbCritical Exit Sub End If Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' حساب آخر صف في العمود B وC وآخر عمود في الصف 2 lr1 = ws.Cells(ws.Rows.Count, 2).End(xlUp).row lr2 = ws.Cells(ws.Rows.Count, 3).End(xlUp).row lc1 = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column ' التحقق من مدى البيانات If lr1 <= 2 Or lr2 <= 2 Or lc1 <= 4 Then MsgBox "مدى البيانات غير صحيح!", vbCritical Application.ScreenUpdating = True Exit Sub End If ' حساب الحد الأقصى للتكرارات لكل اسم max = Application.WorksheetFunction.Ceiling_Math((lc1 - 4) / (lr1 - 2), 1) ' تخزين الأسماء المتاحة في مصفوفة availableNames = ws.Range("B3:B" & lr1).value ' تغيير طريقة تخزين الأسماء totalAttempts = 0 Do While totalAttempts < 5 ' عدد المحاولات الكلية للجدول ' مسح البيانات القديمة ClearOldData ws, lr2, lc1 ' توزيع الأسماء عشوائياً If DistributeNames(ws, lr2, lc1, max, availableNames) Then ' نجحت العملية Exit Do End If totalAttempts = totalAttempts + 1 Loop If totalAttempts >= 5 Then MsgBox "لم يتم العثور على حل بعد عدة محاولات", vbCritical Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Exit Sub End If ' تحديث عدد التعيينات لكل اسم UpdateAssignmentCounts ws, lr1, lr2, lc1 ' تظليل الخلايا المتشابهة Call HighlightDuplicates(ws, lr2, lc1) Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True MsgBox "تم التوزيع بنجاح!", vbInformation End Sub Private Sub ClearOldData(ws As Worksheet, ByVal lr2 As Long, ByVal lc1 As Long) With ws.Range(ws.Cells(3, 4), ws.Cells(lr2, lc1)) .ClearContents .Interior.colorIndex = xlNone End With End Sub Private Function DistributeNames(ws As Worksheet, ByVal lr2 As Long, ByVal lc1 As Long, _ ByVal max As Long, ByVal availableNames As Variant) As Boolean Dim row As Long, col As Long Dim attempt As Long Dim randVal As Variant Dim randIndex As Long Dim namesCount As Long namesCount = UBound(availableNames, 1) For row = 3 To lr2 For col = 4 To lc1 attempt = 0 Do While attempt < 100 ' اختيار اسم عشوائي randIndex = Application.WorksheetFunction.RandBetween(1, namesCount) randVal = availableNames(randIndex, 1) ' التحقق من صحة الوضع If IsValidPlacement(ws, row, col, randVal, max, lr2, lc1) Then ws.Cells(row, col) = randVal Exit Do End If attempt = attempt + 1 Loop If attempt >= 100 Then DistributeNames = False Exit Function End If Next col Next row DistributeNames = True End Function Private Function IsValidPlacement(ws As Worksheet, ByVal row As Long, ByVal col As Long, _ ByVal value As Variant, ByVal max As Long, _ ByVal lr2 As Long, ByVal lc1 As Long) As Boolean ' التحقق من التكرار المجاور If col > 4 Then If ws.Cells(row, col - 1).value = value Then Exit Function End If End If ' التحقق من التكرار الأفقي If Application.CountIf(ws.Range(ws.Cells(row, 4), ws.Cells(row, col - 1)), value) >= max Then Exit Function End If ' التحقق من التكرار الرأسي If Application.CountIf(ws.Range(ws.Cells(3, col), ws.Cells(row - 1, col)), value) > 0 Then Exit Function End If IsValidPlacement = True End Function Private Sub UpdateAssignmentCounts(ws As Worksheet, ByVal lr1 As Long, ByVal lr2 As Long, ByVal lc1 As Long) Dim row As Long For row = 3 To lr1 If Not IsEmpty(ws.Cells(row, 2)) Then ws.Cells(row, 1) = Application.CountIf(ws.Range(ws.Cells(3, 4), ws.Cells(lr2, lc1)), ws.Cells(row, 2)) End If Next row End Sub Private Sub HighlightDuplicates(ws As Worksheet, ByVal lr2 As Long, ByVal lc1 As Long) Dim r As Long, c As Long Dim cell As Range, rngRow As Range, rngCol As Range Dim colorDict As Object Dim uniqueValue As Variant Dim colorIndex As Long ' إنشاء قاموس للألوان Set colorDict = CreateObject("Scripting.Dictionary") ' مجموعة من الألوان المختلفة Dim colors(1 To 10) As Long colors(1) = RGB(255, 200, 200) ' أحمر فاتح colors(2) = RGB(200, 255, 200) ' أخضر فاتح colors(3) = RGB(200, 200, 255) ' أزرق فاتح colors(4) = RGB(255, 255, 200) ' أصفر فاتح colors(5) = RGB(255, 200, 255) ' وردي فاتح colors(6) = RGB(200, 255, 255) ' سماوي فاتح colors(7) = RGB(255, 220, 180) ' برتقالي فاتح colors(8) = RGB(220, 180, 255) ' بنفسجي فاتح colors(9) = RGB(180, 255, 220) ' نعناعي فاتح colors(10) = RGB(240, 240, 180) ' ليموني فاتح colorIndex = 1 ' مسح التنسيق السابق ws.Range(ws.Cells(3, 4), ws.Cells(lr2, lc1)).Interior.colorIndex = xlNone ' تظليل التكرارات في الصفوف For r = 3 To lr2 Set rngRow = ws.Range(ws.Cells(r, 4), ws.Cells(r, lc1)) colorDict.RemoveAll ' إعادة تعيين القاموس لكل صف For Each cell In rngRow If Not IsEmpty(cell) Then uniqueValue = cell.value ' إذا وجد تكرار في نفس الصف If Application.CountIf(rngRow, uniqueValue) > 1 Then ' إذا لم يكن هذا القيمة موجودة في القاموس، أضف لون جديد If Not colorDict.Exists(uniqueValue) Then colorDict.Add uniqueValue, colors(colorIndex) colorIndex = (colorIndex Mod 10) + 1 End If ' تطبيق اللون cell.Interior.Color = colorDict(uniqueValue) End If End If Next cell Next r ' تظليل التكرارات في الأعمدة colorDict.RemoveAll colorIndex = 1 For c = 4 To lc1 Set rngCol = ws.Range(ws.Cells(3, c), ws.Cells(lr2, c)) For Each cell In rngCol If Not IsEmpty(cell) Then uniqueValue = cell.value ' إذا وجد تكرار في نفس العمود If Application.CountIf(rngCol, uniqueValue) > 1 Then ' إذا كانت الخلية ملونة بالفعل (من تكرار الصف) If cell.Interior.Color <> xlNone Then ' تغيير اللون لمزيج من اللونين cell.Interior.Color = RGB(255, 200, 255) ' لون مميز للتكرار في كلا الاتجاهين Else ' إذا لم يكن هذا القيمة موجودة في القاموس، أضف لون جديد If Not colorDict.Exists(uniqueValue) Then colorDict.Add uniqueValue, colors(colorIndex) colorIndex = (colorIndex Mod 10) + 1 End If ' تطبيق اللون cell.Interior.Color = colorDict(uniqueValue) End If End If End If Next cell Next c ' إضافة حدود للخلايا With ws.Range(ws.Cells(3, 4), ws.Cells(lr2, lc1)).Borders .LineStyle = xlContinuous .Weight = xlThin .colorIndex = xlAutomatic End With End Sub

وعليكم السلام ورحمة الله و بركاته نعم، يمكن تعديل الكود ليعمل على فتح الملف من أي كمبيوتر بشرط أن يتم اختيار الملف يدويًا من خلال نافذة اختيار الملفات (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

جزاك الله خيرًا أخي @Ashraf Atteya Abo Zaid، ووفقنا وإياك لما يحب ويرضى

إليك أخي الملف كما طلبت مع تلوين الخلايا حسب الاختيار تسجيل بيانات2.xlsm

جرب جميع شيتات الملف و ما يتناسب معك حسب إصدار الاكسيل عندك ممكن فصله في ملف مستقل.

أخي الكريم أرفق ملف و وضح الطلب قدر الإمكان =NOW()+0.25 بالنسبة للمعادلة فهي تُستخدم لإضافة ربع يوم (6 ساعات) إلى التاريخ والوقت الحاليين

و إياكم أخي الكريم

جرب الملف التالي حسب فهمي للموضوع جدول 2.xlsx

عندي ملف من إعداد الاستاذ مصطفى شرف و قمت بالتعديل عليه الشرح للأستاذ مصطفى من هنا توزيع الملاحظين 2024.xlsm

ملف آخر يشمل سلايسر و معادلات و كود الفلترة2.xlsm

و عليكم السلام ورحمة الله وبركاته الملف مطبق عليه الفلترة باستخدام slicer الفلترة2.xlsx

تفضل أخي و كم كنت أتمنى أن تقوم بتطبيق الدالة بنفسك نظرا لسهولتها Book2 (1).xlsm