hegazee

السلام عليكم ورحمة الله و بركاته المشكلة الرئيسية في هذه الأكواد التي تستخدم في توزيع الملاحظة هي أنها قد تدخل في حلقة لا نهائية عندما لا يمكن إيجاد حل يلبي جميع الشروط. عندما تفرض شروط صارمة على التوزيع (مثل عدم التكرار أو حد التكرار)، فإن هناك احتمالًا أن يفشل الكود في إيجاد توزيع مناسب — مما يؤدي إلى حلقة لا نهائية تقريبا أو وقت تنفيذ طويل جدًا. فمثلا لجنة ثانوية عامة هذا العام بها 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

و عليكم السلام ورحمة الله و بركاته تحياتي للأستاذ @Foksh الألوان تستخدم في كنترول الابتدائي و ذلك لعدم وجود طابعات ألوان فيتم كنتابة اللون . لذلك هناك حل بسيط بالمعادلات حيث يتم لصق المعادلة التالية في الخلية M7 ثم سحبها للأسفل: =IFS(I9>=85;"أزرق"; I9>=65;"أخضر"; I9>=50;"أصفر"; TRUE;"أحمر")

و عليكم السلام ورحمة الله و بركاته أبسط الطرق هي الارتباط التشعبي كما في الملف المرفق. أيضا هناك حلول من خلال الأكواد و المعادلات و لكن هذا أسهل شيء بدون أي تعقيدات و يمكن أن تطبقه بنفسك على ملفات أخرى الحساب2.xlsx

تحياتي للأساتذه @Foksh و @محمد هشام. على الحلول الرائعة. و إثراء للموضوع و استكمالا لما قدمه الأساتذة أقدم إضافة بسيطة لترحيل الاختلافات درجات المواد v4.xlsb

كود رائع للاستاذ @Foksh إليك حل آخر بالتنسيق الشرطي درجات المواد(2).xlsx

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

آمين و إياكم

جرب المعادلة التالية =IF($B10="","",ROUND(VLOOKUP($B10,nageh,25,0), 0)) لا تنسى تحويل الفواصل حسب إصدار الأوفيس عندك

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

برجاء إدراج ملف للعمل عليه

وعليكم السلام و رحمة الله و بركاته أخي الكريم الطلب غير واضح لأن الطلب الأول و الثاني نفس القيمة بالضبط يساوي 250000 مع العلم أنه لاتوجد أي خلية بها هذا الرقم

إن شاء الله يمكنك نسخ محتوى صفحة ويب وتنسيقه في ملف إكسيل باستخدام عدة طرق: 1. النسخ اليدوي من خلال نسخ المحتوى من صفحة الويب ثم لصقها في شيت إكسيل 2. ممكن تستخدم Power Query كالآتي: افتح إكسيل وانتقل إلى علامة التبويب Data أو البيانات. اختر Get Data ثم From Web أو الحصول على بيانات ثم من الويب. أدخل رابط صفحة الويب. ستظهر نافذة تعرض الجداول أو العناصر المتوفرة في الصفحة. اختر الجدول المطلوب. قم بتحميل البيانات إلى إكسيل، ويمكنك تنسيقها بعد ذلك.

و عليكم السلام ورحمة الله و بركاته نعم، يمكنك طباعة الـ UserForm في Excel باستخدام VBA، ولكن يجب أولاً تحويل اليوزر فورم إلى صورة (Bitmap) ثم إرسالها إلى ورقة عمل أو كائن للطباعة. للأسف، الـ VBA لا يدعم طباعة اليوزر فورم مباشرة مثل ورقة العمل. يفضل ارفاق ملف لتوضيح المطلوب. وبعد البحث في منتديات أوفيسنا وجدت الحل و قمت بالتعديل في الكود رابط الملف الأصلي https://www.officena.net/ib/topic/103266-معاينة-الطباعة-على-اليوزر-فورم/#google_vignette و إليك الملف بعد التعديل preview on userform.xlsm

تفضل أخي الفاضل ملفين أحدهما معادلات و الآخر أكواد. اختر ما يحلو لك. ناجح-راسب.xlsm ناجح-راسب.xlsx