تعديل كود توزيع مراقبين

[بلانك]

المطلوب داخل الملف شرط التوزيع شرطين :-

1- عدم تضارب في العمود الواحد و الصف الواحد

2- عدم تكرار المراقب الواحد في اللجنة الواحدة     ....         كما بالملف

مراقبة 2026.xlsm

[hegazee]

ممكن يكون طلبك هنا

https://www.youtube.com/watch?v=M1DhpzkT8kA

 او جرب هذا الكود:

Sub Observer_FullSystem()

    Dim ws As Worksheet, wsReport As Worksheet
    Dim NamesArr() As Variant
    Dim UsedRow As Object, UsedCol As Object, UsedAll As Object
    Dim lrNames As Long, lrRows As Long, lrCols As Long
    Dim r As Long, c As Long, i As Long
    Dim Available() As String
    Dim cnt As Long, MaxAllowed As Long, TotalCells As Long
    Dim TryCount As Long
    Dim MainCols As Long: MainCols = 2   ' عدد الأعمدة الأساسية
    
    Set ws = ActiveSheet
    Application.ScreenUpdating = False
    Randomize

    ' ===== Backup =====
    ws.Copy After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "Backup_" & Format(Now, "ddmmyy_hhmmss")
    ws.Activate

    ' ===== قراءة الأسماء =====
    lrNames = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
    NamesArr = ws.Range("B3:B" & lrNames).Value

    ' ===== حدود الجدول =====
    lrRows = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row
    lrCols = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column

    ws.Range(ws.Cells(3, 4), ws.Cells(lrRows, lrCols)).ClearContents

    ' ===== الحد الأقصى =====
    TotalCells = (lrRows - 2) * (lrCols - 3)
    MaxAllowed = Application.WorksheetFunction.RoundUp(TotalCells / (lrNames - 2), 0)

    Set UsedAll = CreateObject("Scripting.Dictionary")

    ' ===== التوزيع =====
    For r = 3 To lrRows
        Set UsedRow = CreateObject("Scripting.Dictionary")

        For c = 4 To lrCols
            TryCount = 0

RetryCell:
            TryCount = TryCount + 1
            If TryCount > 300 Then GoTo NextCell

            Set UsedCol = CreateObject("Scripting.Dictionary")
            For i = 3 To r - 1
                If ws.Cells(i, c).Value <> "" Then UsedCol(ws.Cells(i, c).Value) = 1
            Next i

            cnt = 0
            ReDim Available(1 To UBound(NamesArr, 1))

            For i = 1 To UBound(NamesArr, 1)
                If Not UsedRow.exists(NamesArr(i, 1)) _
                And Not UsedCol.exists(NamesArr(i, 1)) Then

                    If Not UsedAll.exists(NamesArr(i, 1)) _
                    Or UsedAll(NamesArr(i, 1)) < MaxAllowed Then
                        cnt = cnt + 1
                        Available(cnt) = NamesArr(i, 1)
                    End If
                End If
            Next i

            If cnt > 0 Then
                ws.Cells(r, c).Value = Available(Int(Rnd * cnt) + 1)
                UsedRow(ws.Cells(r, c).Value) = 1

                UsedAll(ws.Cells(r, c).Value) = UsedAll(ws.Cells(r, c).Value) + 1
            Else
                GoTo RetryCell
            End If

NextCell:
        Next c
    Next r

    ' ===== تقرير =====
    On Error Resume Next
    Set wsReport = Sheets("تقرير")
    On Error GoTo 0

    If wsReport Is Nothing Then
        Set wsReport = Sheets.Add
        wsReport.Name = "تقرير"
    Else
        wsReport.Cells.Clear
    End If

    wsReport.Range("A1:D1") = Array("الاسم", "الإجمالي", "أساسي", "احتياطي")

    For i = 3 To lrNames
        wsReport.Cells(i - 2, 1) = ws.Cells(i, 2)
        wsReport.Cells(i - 2, 2) = Application.CountIf(ws.Range(ws.Cells(3, 4), ws.Cells(lrRows, lrCols)), ws.Cells(i, 2))
        wsReport.Cells(i - 2, 3) = Application.CountIf(ws.Range(ws.Cells(3, 4), ws.Cells(lrRows, 3 + MainCols)), ws.Cells(i, 2))
        wsReport.Cells(i - 2, 4) = wsReport.Cells(i - 2, 2) - wsReport.Cells(i - 2, 3)
    Next i

    wsReport.Columns.AutoFit

    Application.ScreenUpdating = True
    MsgBox "تم التوزيع + إنشاء نسخة احتياطية + تقرير كامل ?", vbInformation

End Sub

 

تم تعديل ديسمبر 21, 2025 بواسطه hegazee

[بلانك]

للاسف الملف يعطي كما بالصورة وتركته اكثر من 10 دقائق لتنفيذ الكود بلا جدوى ... ما السبب؟؟؟؟؟؟؟؟؟

تم تعديل ديسمبر 24, 2025 بواسطه بلانك
الخطأ من عندي والكود يعمل بكفاءة

[بلانك]

بارك الله فيك استاذنا الاستاذ / حجازي وجعله الله في ميزان حسناتك 

[hegazee]

آمين. جزاك الله خيرا