hegazee

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

و عليكم السلام ورحمة الله و بركاته جرب الملف المرفق (2)استخراج_فواتير_بدون_تكرار.xlsx

و عليكم السلام ورحمة الله وبركاته حسب فهمي للملف أن الكود يحول البيانات إلى أرقام و تواريخ حسب العمود. و لا أعرف لماذا تمت تسمية زر تشغيل الكود بلصق الاختيارت. قمت بتعديل أشاء بسيطة بالكود للتأكد من تنسيق الخلايا حسب المطلوب بس تأكد من التواريخ المكتوبة يوم و شهر تجرة(2).xlsb

بعد إذن الاستاذ/ هشام جرب كود الأستاذ/هشام بعد تعديل بسيط Option Explicit Sub Transfer() Dim code As Variant, c As Boolean Dim tmp(0 To 4) As Boolean, xDate As String Dim f As Long, i As Long, j As Long Dim linge As Long, xCode As Boolean, Irow As Range Dim ColArr As Long, xName As String, n As Variant, val As Variant Dim lastRow As Long Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2") Dim Data As Worksheet: Set Data = Sheets("Sheet3") ' التحقق من وجود التاريخ xDate = Format(CrWS.Range("D2").Value, "dd/mm/yyyy") If xDate = "" Then MsgBox "المرجوا تحديد التاريخ", vbInformation Exit Sub End If ' البحث عن العمود المطابق للتاريخ في الصف 3 With Data For ColArr = .Columns("E").Column To .Cells(3, .Columns.Count).End(xlToLeft).Column If Format(.Cells(3, ColArr).Value, "dd/mm/yyyy") = xDate Then f = ColArr Exit For End If Next ColArr If f = 0 Then MsgBox "لم يتم العثور على التاريخ", vbExclamation Exit Sub End If End With ' تحديد آخر صف يحتوي أكواد في العمود C من Sheet2 lastRow = CrWS.Cells(CrWS.Rows.Count, "C").End(xlUp).Row xCode = False: c = False ' البدء من الصف 11 حتى يشمل أول طالب For i = 11 To lastRow code = CrWS.Cells(i, "C").Value If code <> "" Then linge = Data.Cells(Data.Rows.Count, "D").End(xlUp).Row n = Application.Match(code, Data.Range("D6:D" & linge), 0) If Not IsError(n) Then xCode = True ' مسح الصف الخاص بالكود الحالي فقط For ColArr = 0 To 4 Data.Cells(n + 5, f + ColArr).ClearContents Next ColArr ' نقل القيم For j = 0 To 4 xName = CrWS.Cells(10, 4 + j).Value For ColArr = 0 To 4 If Data.Cells(4, f + ColArr).Value = xName Then val = CrWS.Cells(i, 4 + j).Value If Not IsEmpty(val) Then Data.Cells(n + 5, f + ColArr).Value = val c = True If Not tmp(j) Then Data.Cells(5, f + ColArr).Value = CrWS.Cells(11, 4 + j).Value tmp(j) = True End If End If Exit For End If Next ColArr Next j End If End If Next i ' رسائل النهاية If Not xCode Then MsgBox "لم يتم العثور على أي أكواد مطابقة", vbExclamation ElseIf c Then MsgBox "تم ترحيل البيانات بنجاح", vbInformation Else MsgBox "لا توجد بيانات لترحيلها", vbInformation End If End Sub غياب3.xlsm

حاول ترفع أي ملف فيه مشكله هنا. و إذا كان حجمه كبير ارفعه على جوجل درايف

تفضل الملف . حطيت بعض المعلومات العشوائية لاختبار المعادلة شهر 12022(2).xlsx

من الأفضل رفع ملف ليتم العمل عليه

تفضل Sub FormatUniqueCellsInRow() Dim ws As Worksheet Dim lastRow As Long, startRow As Long Dim r As Long, i As Long, j As Long Dim values(1 To 7) As Variant Dim count As Long Dim data As Variant On Error GoTo ErrorHandler Set ws = ThisWorkbook.Sheets("Sheet1") ' تأكد من تغيير "Sheet1" إلى اسم الورقة الفعلي startRow = 3 ' الصف الذي تبدأ منه البيانات lastRow = ws.Range("C3:I" & ws.Rows.Count).Find(What:="*", _ SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ' تنظيف التنسيقات السابقة من الأعمدة C:I و O With ws.Range("C" & startRow & ":I" & lastRow & ",O" & startRow & ":O" & lastRow) .Interior.ColorIndex = xlNone .Font.ColorIndex = xlAutomatic .Font.Bold = False End With ' تحميل النطاق إلى مصفوفة data = ws.Range("C" & startRow & ":I" & lastRow).Value ' المرور على كل صف For r = 1 To lastRow - startRow + 1 ' تخزين قيم الصف الحالي For i = 1 To 7 values(i) = data(r, i) Next i ' فحص القيم الفريدة For i = 1 To 7 count = 0 If Not IsEmpty(values(i)) Then For j = 1 To 7 If CStr(values(j)) = CStr(values(i)) Then count = count + 1 End If Next j ' إذا كانت القيمة فريدة If count = 1 Then ' تطبيق التنسيق على الخلية في C:I With ws.Cells(r + startRow - 1, i + 2) .Interior.Color = RGB(255, 255, 0) ' تعبئة صفراء .Font.Color = RGB(255, 0, 0) ' خط أحمر .Font.Bold = True ' خط عريض End With ' تطبيق نفس التنسيق على الخلية في العمود O في نفس الصف With ws.Cells(r + startRow - 1, "O") .Interior.Color = RGB(255, 255, 0) ' تعبئة صفراء .Font.Color = RGB(255, 0, 0) ' خط أحمر .Font.Bold = True ' خط عريض End With End If End If Next i Next r MsgBox "تمت معالجة البيانات بنجاح!", vbInformation Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Sub

بعد إذن أساتذتي حل بالمعادلات بشكل مبسط BB (3).xlsx

جرب الكود التالي: Sub CheckDifferences() Dim ws As Worksheet Dim lastRow As Long Dim r As Long Dim values(1 To 7) As Variant Dim result As String Dim i As Integer, j As Integer Dim count As Integer Dim isFirstDiff As Boolean Set ws = ThisWorkbook.Sheets("Sheet1") ' ✏️ غيّر اسم الشيت إذا لزم lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row ' تنظيف العمود O قبل الكتابة ws.Range("O3:O" & lastRow).ClearContents ws.Range("O3:O" & lastRow).Interior.ColorIndex = xlNone ws.Range("O3:O" & lastRow).Font.ColorIndex = xlAutomatic For r = 3 To lastRow ' قراءة القيم من C إلى I For i = 1 To 7 values(i) = ws.Cells(r, i + 2).Value Next i result = "" isFirstDiff = True For i = 1 To 7 count = 0 For j = 1 To 7 If values(j) = values(i) Then count = count + 1 Next j If count = 1 Then If Not isFirstDiff Then result = result & " و " End If result = result & "العمود " & Chr(64 + i + 2) & " مختلف" isFirstDiff = False End If Next i With ws.Cells(r, 15) ' العمود O .Value = Trim(result) If result <> "" Then .Interior.Color = vbYellow ' تعبئة باللون الأصفر .Font.Color = vbRed ' الخط باللون الأحمر End If End With Next r End Sub

و عليكم السلام ورحمة الله وبركاته أسهل شيء استخدام التنسيق الشرطي (2)2025 اسم التوكيل.xlsm

تفضل أخي ملفين الملف الأول: يقوم بطباعة أوراق العمل حسب ما تكتبه من نطاقات في كل رسالة تظهر الملف الثاني : ما عليك إلا كتابة نطاق طباعة كل صفحة في الخلية A1 و البرنامج يقوم بطباعتها ملاحظات: · إذا اختار المستخدم الطباعة، تطبع جميع الأوراق في دفعة واحدة. · إذا اختار حفظ PDF، تنسخ هذه الأوراق إلى مصنف مؤقت ثم يصدر إلى PDF. *عند التصدير بصيغة PDF اختر مجلد لحفظ ملف الطباعة فيه *أهم شيء تنسيق الصفحات و الهوامش حيث لاحظت أن بعض الصفحات تتم طباعتها على ورقتين لعدم ضبط المسافات و الحدود أيضا عند تغيير أسماء أوراق العمل في الملف الأول لابد أن تغيرها في الكود. طباعة اكثر من صفحة.xlsb طباعة اكثر من صفحة من خلال خلية.xlsb

وعليكم السلام ورحمة الله و بركاته Sub PrintOrExportPDF_CustomRanges() Dim ws As Worksheet Dim rngAddress As String Dim sheetNames As Variant Dim printableSheetNames() As String Dim i As Integer, count As Integer Dim printChoice As VbMsgBoxResult Dim savePath As String Dim fileName As String ' أسماء الأوراق (عدّل حسب أوراقك) sheetNames = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4") count = 0 ' سؤال المستخدم: طباعة أم PDF؟ printChoice = MsgBox("هل ترغب في طباعة الأوراق؟" & vbCrLf & "اضغط 'نعم' للطباعة، 'لا' لحفظ كـ PDF.", vbYesNoCancel + vbQuestion, "اختيار نوع الإخراج") If printChoice = vbCancel Then MsgBox "تم إلغاء العملية.", vbExclamation Exit Sub End If Application.ScreenUpdating = False ' تحديد النطاقات For i = LBound(sheetNames) To UBound(sheetNames) Set ws = ThisWorkbook.Sheets(sheetNames(i)) rngAddress = InputBox("أدخل النطاق المطلوب طباعته من الورقة: " & sheetNames(i), "تحديد نطاق الطباعة") If rngAddress <> "" Then On Error Resume Next ws.PageSetup.PrintArea = rngAddress If Err.Number = 0 Then count = count + 1 ReDim Preserve printableSheetNames(1 To count) printableSheetNames(count) = ws.Name End If On Error GoTo 0 Else MsgBox "تم تخطي الورقة: " & sheetNames(i), vbInformation End If Next i ' تنفيذ العملية حسب الاختيار If count > 0 Then If printChoice = vbYes Then ' ? طباعة مباشرة Sheets(printableSheetNames).PrintOut MsgBox "تمت طباعة الأوراق المحددة بنجاح.", vbInformation ElseIf printChoice = vbNo Then ' ? تصدير كـ PDF (بمصنف مؤقت) With Application.FileDialog(msoFileDialogFolderPicker) .Title = "اختر المجلد لحفظ ملف PDF" If .Show <> -1 Then MsgBox "لم يتم اختيار مجلد.", vbExclamation Exit Sub End If savePath = .SelectedItems(1) End With fileName = InputBox("أدخل اسم ملف PDF بدون .pdf", "اسم الملف") If fileName = "" Then MsgBox "لم يتم إدخال اسم الملف.", vbExclamation Exit Sub End If ' إنشاء مصنف مؤقت Dim tempBook As Workbook Set tempBook = Workbooks.Add ' نسخ الأوراق للمصنف المؤقت For i = 1 To count ThisWorkbook.Sheets(printableSheetNames(i)).Copy After:=tempBook.Sheets(tempBook.Sheets.count) Next i ' حذف الورقة الافتراضية الفارغة Application.DisplayAlerts = False Do While tempBook.Sheets.count > count tempBook.Sheets(1).Delete Loop Application.DisplayAlerts = True ' حفظ كـ PDF tempBook.ExportAsFixedFormat _ Type:=xlTypePDF, _ fileName:=savePath & "\" & fileName & ".pdf", _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=True ' إغلاق المصنف المؤقت بدون حفظ tempBook.Close SaveChanges:=False MsgBox "تم حفظ ملف PDF بنجاح.", vbInformation End If Else MsgBox "لم يتم تحديد أي ورقة للطباعة أو التصدير.", vbExclamation End If Application.ScreenUpdating = True End Sub

نعم، برنامج الأوفيس ومن ضمنه Excel متوفر بنسختين: إصدار 32bit و إصدار 64bit

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

و عليكم السلام الكود التالي يحقق المطلوب فقط تأكد من أن الملفين في نفس المسار Sub Button1_Click() Dim Wb1 As Workbook, Wb2 As Workbook, FilePath As String, OnRng As Range Dim WSdata As Worksheet, WSdest As Worksheet, WSname As String WSname = "إدخال بيانات أساسية" ' تأكد من أن الاسم مطابق تمامًا On Error GoTo ErrorHandler Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False ' تحديد مسار الملف FilePath = ThisWorkbook.Path & "\Book2.xlsb" ' تأكد من امتداد الملف ' التحقق من وجود الملف If Dir(FilePath) = "" Then MsgBox "ملف Book2 غير موجود في المسار: " & vbCrLf & FilePath, vbExclamation Exit Sub End If ' فتح الملف بكلمة المرور Set Wb1 = Workbooks.Open(FilePath, Password:="123") ' تأكد من كلمة المرور Set Wb2 = ThisWorkbook ' التحقق من وجود ورقة العمل Set WSdata = Wb1.Sheets(WSname) Set WSdest = Wb2.Sheets(WSname) If WSdata Is Nothing Or WSdest Is Nothing Then MsgBox "ورقة العمل '" & WSname & "' غير موجودة في أحد الملفين", vbCritical Wb1.Close False Exit Sub End If ' نسخ البيانات Set OnRng = WSdata.UsedRange If OnRng.Cells.CountLarge = 1 And IsEmpty(OnRng.Value) Then MsgBox "لا توجد بيانات في الورقة المصدر", vbExclamation Wb1.Close False Exit Sub End If WSdest.Cells.UnMerge WSdest.Cells.ClearContents OnRng.Copy With WSdest.Range("A1") .PasteSpecial xlPasteFormulas .PasteSpecial xlPasteFormats End With Application.CutCopyMode = False Wb1.Close False MsgBox "تم نسخ البيانات بنجاح", vbInformation ExitHandler: Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical Resume ExitHandler End Sub

و عليكم السلام ورحمة الله و بركاته ثبت إصدار 64 بت من Office على اللاب توب الجديد لأنه إذا كان Office على اللاب توب 32 بت، فقد يكون هذا هو سبب المشكلة، لأن الماكرو التي تم إنشاؤها على 64 بت لا تعمل بشكل صحيح. افتح Excel على اللاب توب، واذهب إلى: ملف > خيارات > مركز التوثيق > (Trust Center) > إعدادات مركز التوثيق > إعدادات الماكرو. اختر تمكين جميع وحدات الماكرو أو تعطيل وحدات الماكرو مع الإشعار للسماح بتفعيل الماكرو يدويًا عند فتح الملف.

آمين يا رب العالمين. و إياكم أجمعين

و أنتم بخير . جرب الكود التالي في الملف الأول Sub Button1_Click() Dim Wb1 As Workbook, Wb2 As Workbook, FilePath As String, OnRng As Range Dim WSdata As Worksheet, WSdest As Worksheet, WSname As String: WSname = "ملف 1" Application.ScreenUpdating = False Application.Calculation = xlCalculationManual With Application.FileDialog(msoFileDialogFilePicker) .Title = "اختر ملف Excel كمصدر للبيانات" .Filters.Clear: .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsb" If .Show <> -1 Then MsgBox "لم يتم اختيار أي ملف", vbExclamation: Exit Sub FilePath = .SelectedItems(1) End With Set Wb1 = Workbooks.Open(FilePath) Set Wb2 = ThisWorkbook On Error Resume Next Set WSdata = Wb1.Sheets(WSname) Set WSdest = Wb2.Sheets(WSname) On Error GoTo 0 If WSdata Is Nothing Or WSdest Is Nothing Then MsgBox "لم يتم العثور على ورقة العمل", vbCritical Wb1.Close False Exit Sub End If ' تحديد النطاق من F9 إلى S609 Set OnRng = WSdata.Range("F9:S609") WSdest.Cells.UnMerge WSdest.Range("F9:S609").ClearContents ' مسح النطاق المحدد فقط OnRng.Copy With WSdest.Range("F9") .PasteSpecial xlPasteFormulas .PasteSpecial xlPasteFormats End With Application.CutCopyMode = False Application.Goto WSdest.Range("F9"), True Wb1.Close False Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True MsgBox "تم نسخ البيانات بنجاح", vbInformation End Sub

و عليكم السلام ورحمة الله و بركاته جرب الكود التالي في حدث الصفحة Private Sub Worksheet_Change(ByVal Target As Range) Dim cell As Range Dim inputValue As String Dim parts() As String Dim secondPart As String Dim hasLetter As Boolean Dim letterPos As Integer Dim i As Integer Dim errorMsg As String ' التحقق من أن التغيير حدث في العمود E (العمود الخامس) If Not Intersect(Target, Me.Columns(5)) Is Nothing Then Application.EnableEvents = False ' تعطيل الأحداث مؤقتًا لتجنب التكرار For Each cell In Intersect(Target, Me.Columns(5)) If Not IsEmpty(cell) Then inputValue = Trim(cell.Value) errorMsg = "" ' التحقق من وجود الشرطة المائلة (/) If InStr(inputValue, "/") > 0 Then errorMsg = errorMsg & "خطأ: يجب استخدام الشرطة العادية (-) بدلاً من الشرطة المائلة (/)." & vbCrLf End If ' التحقق من التنسيق العام If InStr(inputValue, "-") > 0 Then parts = Split(inputValue, "-") If UBound(parts) = 1 Then secondPart = parts(1) ' التحقق من وجود صفر في بداية الجزء الثاني If Left(secondPart, 1) = "0" Then errorMsg = errorMsg & "خطأ: لا يُسمح بوجود صفر (0) بعد الشرطة (-)." & vbCrLf End If ' التحقق من وجود حرف إنجليزي في الجزء الثاني hasLetter = False letterPos = 0 For i = 1 To Len(secondPart) If secondPart Like "*[a-zA-Z]*" Then hasLetter = True Exit For End If Next i ' التحقق من وجود صفر بعد الحرف الإنجليزي (إن وجد) If hasLetter Then letterPos = InStr(secondPart, Left(secondPart, 1)) If letterPos > 0 And Mid(secondPart, letterPos + 1, 1) = "0" Then errorMsg = errorMsg & "خطأ: لا يُسمح بوجود صفر (0) بعد الحرف الإنجليزي." & vbCrLf End If End If Else errorMsg = errorMsg & "خطأ: تنسيق رقم الحالة غير صحيح. يجب أن يكون على شكل (أرقام-أرقام) أو (أرقام-حرف أرقام)." & vbCrLf End If Else errorMsg = errorMsg & "خطأ: يجب أن يحتوي رقم الحالة على شرطة عادية (-)." & vbCrLf End If ' إذا كان هناك خطأ، عرض رسالة تحذير وإلغاء الإدخال If errorMsg <> "" Then MsgBox errorMsg, vbCritical, "خطأ في إدخال رقم الحالة" cell.Value = "" End If End If Next cell Application.EnableEvents = True ' إعادة تفعيل الأحداث End If End Sub Book1.xlsm

الملف المرسل في مشاركة سابقة ممتاز و يعمل بكفاءة و يوزع عدد 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