بطئ كود توزيع الملاحظين على اللجان

[بلانك]

عند توزيع الملاحظين على اللجان وعددها 30 لجنة ثانوية عامة وعدد الملاحظين 65 كود التوزيع بطئ جدا جدا وياخذ وقت طويل جدا   ...... برجاء تعديل الكود او إنشاء كود جديد .... بشرط : 1- عدم تكرار ملاحظ في نفس اللجنة بحيث يمر على جميع اللجان بقدر الامكان  طوال الامتحانات .      2- تساوي مرات دخول  الملاحظين  على اللجان قدر الامكان.

ملاحظة_ث.ع.xlsm

[Foksh]

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

في البداية أعتقد أن الفكرة قد تكون متشعبة نوعاً ما ، بالإعتماد على النتائج التي قد تحتلف في كل مرة يتم فيها النقر على زر "توزيع الملاحظين" . لذا بعد تجربتك لهذه الفكرة البسيطة ، أخبرنا بالنتيجة وبالتفصيل . مع العلم أنه يوجد لديك فكرتين ، ومن خلال تجربتك ومتابعتك للنتائج ، اخبرنا بتفاصيل النتائج التي عادت لك .

شرح الفكرة الأولى التي تمت :-

• السرعة في التوزيع ، حيث يعمل الكود بشكل أسرع بكثير لأنه :-

1. يستخدم مصفوفات للتعامل مع البيانات بدلاً من الخلايا مباشرة .
2. يعطل التحديث التلقائي وإعادة الحساب أثناء التنفيذ .

• ضمان عدم تكرار الملاحظ في نفس اللجنة :-

1. يستخدم خوارزمية توزيع دائرية تضمن عدم التكرار في اللجنة الواحدة .

• التوزيع العادل :-

1. يحاول توزيع الملاحظين على اللجان بالتساوي قدر الإمكان .
2. يمر كل ملاحظ على جميع اللجان خلال فترات الامتحانات .

 

• الكود الذي تم استخدامه لهذه الفكرة ( مع دالة بسيطة مساعدة ) :-

Sub DistributeObservers()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    On Error GoTo ErrorHandler
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("الثانوية العامة")
    
    Dim observers As Range, committees As Range
    Dim observerCount As Long, committeeCount As Long
    Dim distributionRange As Range
    Dim i As Long, j As Long, attempts As Long
    Dim observerList() As Variant, committeeList() As Variant
    Dim distributionArray() As Variant
    Dim observerUsage() As Long
    
    Set observers = ws.Range("B3:B" & ws.Cells(ws.Rows.Count, "B").End(xlUp).row)
    observerCount = observers.Count
    observerList = observers.Value
    
    committeeCount = 30
    ReDim committeeList(1 To committeeCount)
    For i = 1 To committeeCount
        committeeList(i) = "لجنة " & i
    Next i
    
    Set distributionRange = ws.Range("D3").Resize(observerCount, committeeCount)
    
    ReDim distributionArray(1 To observerCount, 1 To committeeCount)
    ReDim observerUsage(1 To observerCount)
    
    Dim randomizedObservers() As Variant
    randomizedObservers = ShuffleArray(observerList)
    
    For j = 1 To committeeCount
        For i = 1 To observerCount
            distributionArray(i, j) = randomizedObservers((i + j - 2) Mod observerCount + 1, 1)
            observerUsage((i + j - 2) Mod observerCount + 1) = observerUsage((i + j - 2) Mod observerCount + 1) + 1
        Next i
    Next j
    
    distributionRange.Value = distributionArray
    
    For i = 1 To observerCount
        ws.Cells(i + 2, 1).Value = Application.CountIf(distributionRange, observerList(i, 1))
    Next i
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox "تم التوزيع بنجاح!", vbInformation + vbMsgBoxRight, ""
    Exit Sub
    
ErrorHandler:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox "حدث خطأ: " & Err.Description, vbCritical + vbMsgBoxRight, ""
End Sub

Function ShuffleArray(arr As Variant) As Variant
    Dim i As Long, j As Long
    Dim temp As Variant
    
    For i = UBound(arr) To LBound(arr) + 1 Step -1
        j = Int((i - LBound(arr) + 1) * Rnd + LBound(arr))
        temp = arr(i, 1)
        arr(i, 1) = arr(j, 1)
        arr(j, 1) = temp
    Next i
    
    ShuffleArray = arr
End Function

 

 

شرح الفكرة الثانية التي تمت :-

بالذهاب الى التخلص من الدوال المساعدة ، أو تقييد الفكرة السابقة ، حيث تم استنباط فكرة أخرى تعمل على :-

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

3. معالجة البيانات كمصفوفات بدلاً من نطاقات خلايا !!!!!

4.  

   تقليل الوصول إلى ورقة العمل ، مما يساعد على الوصول الى نتيجة أسرع .

5.  

   اعتماد فكرة رسائل أكثر وصفية و تحتوي على أرقام الملاحظين واللجان .

 

 

 

الكود الذي تم استخدامه لهذه الفكرة :-

Sub DistributeObservers()
    On Error GoTo ErrorHandler
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("الثانوية العامة")
    Dim observers As Variant: observers = ws.Range("B3", ws.Cells(ws.Rows.Count, "B").End(xlUp)).Value
    Dim observerCount As Long: observerCount = UBound(observers)
    Dim committeeCount As Long: committeeCount = 30
    
    ws.Range("A3:A" & observerCount + 2).ClearContents
    ws.Range("D3").Resize(observerCount, committeeCount).ClearContents
    
    Dim i As Long, j As Long
    For j = 1 To committeeCount
        For i = 1 To observerCount
            ws.Cells(i + 2, j + 3).Value = observers((i + j - 2) Mod observerCount + 1, 1)
        Next i
    Next j
    
    For i = 1 To observerCount
        ws.Cells(i + 2, 1).Value = Application.CountIf(ws.Range("D3").Resize(observerCount, committeeCount), observers(i, 1))
    Next i
    
    MsgBox "تم توزيع " & observerCount & " ملاحظاً على " & committeeCount & " لجنة بنجاح", vbInformation + vbMsgBoxRight, "إنجاز"
    
ErrorHandler:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    If Err.Number <> 0 Then MsgBox "خطأ " & Err.Number & ": " & Err.Description, vbCritical, "خطأ"
End Sub

 

وطبعاً في كلا الحالتين ، تم اضافة دالة ماكرو بسيطة لمسح القيم وتنظيف الجدول من التوزيعات :-

Sub ClearDistribution()
    Application.ScreenUpdating = False
    On Error Resume Next
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("الثانوية العامة")
    
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).row
    
    ws.Range("D3:AH" & lastRow).ClearContents
    
    ws.Range("A3:A" & lastRow).ClearContents
    
    Application.ScreenUpdating = True
    MsgBox "تم مسح بيانات التوزيع بنجاح", vbInformation + vbMsgBoxRight, ""
End Sub

 

الملفين للفكرتين :-

1. ملاحظة_ث.ع - 1.xlsm
2. ملاحظة_ث.ع - 2.xlsm

[بلانك]

بارك الله فيكFoksh  .... الكود سريع وجميل جدا جعلة الله في ميزان حستاتك

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

[Foksh]

49 دقائق مضت, بلانك said:

بارك الله فيكFoksh  .... الكود سريع وجميل جدا جغلة الله في ميزان حستاتك

العفو أخي الكريم ، يسعدني أنه لبى حاجتكم  .