الكود يوزع عادي ولكن يكرر الاسماء افقيا (صف) وراسيا (عمود)

[بلانك]

المطلوب داخل الملف ..... وهنال العديد من هذة البرامج ولكن يظهر بها الاخطاء في التوزيع

كود.xlsx

[Foksh]

وعليكم السلام وحمة الله وبركاته ,,

هلا شاركتنا بكود التوزيع الذي يقوم بالتوزيع ؟؟؟

 

[بلانك]

Sub Observer222()
ActiveSheet.Unprotect "0"
Dim password As String, x As Long
password = "0"
If Application.InputBox("inter password", "login") <> password Then

MsgBox "worng password", vbInformation, "error"
Exit Sub
End If
    Dim row As Integer, col As Integer, r As Integer, c As Integer, n As Integer
    Dim lr1 As Integer, lr2 As Integer, lc1 As Integer
    Dim max As Integer
    
    Application.ScreenUpdating = False

    On Error Resume Next
    
    Worksheets("ÇáÍÇÑÓ ÇáÇæá").Select
    
    lr1 = Cells(Rows.Count, 2).End(xlUp).row
    lr2 = Cells(Rows.Count, 3).End(xlUp).row
  
    lc1 = Cells(2, Columns.Count).End(xlToLeft).Column - 0

    max = (lc1 - 4) / (lr1 - 2)

    If max > Fix(max) Then max = max + 1
    
    Range(Cells(3, 4), Cells(lr2, lc1)).ClearContents
    n = Round(Application.CountBlank(Range(Cells(3, 4), Cells(lr2, lc1))) / (lr1 - 2))

    For row = 3 To lr2
        DoEvents
        For col = 4 To lc1
1:
            DoEvents
            Cells(row, col) = Application.Index(Range("b3:b" & lr1), Application.RandBetween(1, lr1 - 2))
            
            
            If Application.CountIf(Range(Cells(row, col - 1), Cells(row, col)), Cells(row, col)) <> 1 Or _
               Application.CountIf(Range(Cells(row, 4), Cells(row, lc1)), Cells(row, col)) > max Or _
               Application.CountIf(Range(Cells(3, col), Cells(lr2, col)), Cells(row, col)) <> 1 Then
                GoTo 1
            End If
2:
        Next col
    Next row

    For c = 3 To lr1
        DoEvents
        Cells(c, 1) = Application.CountIf(Range(Cells(3, 4), Cells(lr2, lc1)), Cells(c, 2))
    Next

    Application.ScreenUpdating = True
    MsgBox "Done"
    ActiveSheet.Protect "0"
End Sub
 

[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

 

[بلانك]

اولا شكرا على تعبك ولكن غند تنفيذ  الكود يعطي خطأ لاحظ الصورة

تم تعديل منذ 8 ساعات بواسطه بلانك

[بلانك]

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

[hegazee]

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

كود (1).xlsm

[بلانك]

للاسف يعطي عند التنفيذ ويمسح ارقام الملاحظين انظر الى الصورتين

[hegazee]

ما المقصود بعدد الملاحظين حيث الأرقام في العمود متسلسلة؟

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

[بلانك]

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

تم تعديل منذ 5 ساعات بواسطه بلانك

[hegazee]

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

توزيع الملاحظين .xlsm

تم تعديل منذ 4 ساعات بواسطه hegazee

[Foksh]

جرب هذا التعديل أخي الكريم :-

 

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

 

[بلانك]

بارك الله فيك هو دا المطلوب