توزيع الطلاب على اللجان بالتساوى

[عادل جلال]

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

المطلوب توزيع عدد الطلبة
على اللجان بشرط لا يزيد عدد الطلاب
 فى أى لجنة عن 29 طالب
وان يكون العدد متساوى أويزيد واحد على الأكثر كما هو موضح

وجزاكم الله خير الجزاء

التوزيع.xlsx

[عبدالله بشير عبدالله]

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

الكود 

Sub DistributeStudents()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim dataRange As Variant
    Dim outputRange As Variant
    Dim rowNum As Long, colNum As Long
    Dim colStart As Integer, colEnd As Integer
    Dim totalStudents As Long, committees As Long
    Dim studentsPerCommittee As Long, extraStudents As Long
    Dim failedRows As String
    Const MaxStudentsPerCommittee As Long = 29

    Set ws = ThisWorkbook.Sheets("ورقة1")

    lastRow = ws.Cells(ws.Rows.Count, 9).End(xlUp).row

    colStart = 11
    colEnd = 30

    ' Clear the output range
    ws.Range(ws.Cells(2, colStart), ws.Cells(lastRow, colEnd)).ClearContents
    ws.Range("I2:I" & lastRow).Interior.Color = xlNone ' إزالة أي ألوان سابقة

    dataRange = ws.Range("I2:J" & lastRow).Value

    ReDim outputRange(1 To UBound(dataRange, 1), colStart To colEnd)
    failedRows = ""
    For rowNum = 1 To UBound(dataRange, 1)
        totalStudents = dataRange(rowNum, 1)
        committees = dataRange(rowNum, 2)

        If committees > (colEnd - colStart + 1) Then
            MsgBox "عدد اللجان في الصف " & rowNum + 1 & " يتجاوز الحد الأقصى للأعمدة المتاحة!", vbExclamation
            Exit Sub
        End If

        If totalStudents = 0 Or committees = 0 Then
            For colNum = colStart To colEnd
                outputRange(rowNum, colNum) = ""
            Next colNum
        Else
            If totalStudents > committees * MaxStudentsPerCommittee Then
                ws.Cells(rowNum + 1, 9).Interior.Color = RGB(255, 0, 0)
                For colNum = colStart To colEnd
                    outputRange(rowNum, colNum) = ""
                Next colNum
                failedRows = failedRows & (rowNum + 1) & ", "
            Else
                studentsPerCommittee = totalStudents \ committees
                extraStudents = totalStudents Mod committees

                For colNum = colStart To colStart + committees - 1
                    If extraStudents > 0 Then
                        outputRange(rowNum, colNum) = studentsPerCommittee + 1
                        extraStudents = extraStudents - 1
                    Else
                        outputRange(rowNum, colNum) = studentsPerCommittee
                    End If
                Next colNum

                For colNum = colStart + committees To colEnd
                    outputRange(rowNum, colNum) = ""
                Next colNum
            End If
        End If
    Next rowNum

    ws.Range(ws.Cells(2, colStart), ws.Cells(lastRow, colEnd)).Value = outputRange

    If failedRows <> "" Then
        failedRows = Left(failedRows, Len(failedRows) - 2) ' إزالة الفاصلة الأخيرة
        MsgBox "تم توزيع الطلاب على اللجان بنجاح! ولكن لم يتم توزيع الطلاب في الصفوف التالية بسبب تجاوز الحد الأقصى لعدد الطلبة على عدداللجان: " & vbCrLf & failedRows, vbExclamation
    Else
        MsgBox "تم توزيع الطلاب على اللجان بنجاح!", vbInformation
    End If
End Sub

الملف

 التوزيع.xlsb

 

تم تعديل ديسمبر 2 بواسطه عبدالله بشير عبدالله

[بلانك]

بعد تجربة الملف وعند توزيع 1000طالب . وضع في كل لجنة  250 طالب وهذا لايمكن . لذا ارجو من حضرتك يكون الحد الاقصى للجنة هو 30 طالب فقط

[عبدالله بشير عبدالله]

5 ساعات مضت, بلانك said:

بعد تجربة الملف وعند توزيع 1000طالب . وضع في كل لجنة  250 طالب وهذا لايمكن . لذا ارجو من حضرتك يكون الحد الاقصى للجنة هو 30 طالب فقط

تم التعديل في المشاركة السايقة حمل الملف من جديد ولكن العدد 29 طالب حسب طلب  صاحب الطلب  عادل جلال وبمكن تعديلها من الكود لاي رقم تشاء 

[بلانك]

تمام بارك الله فيك استاذنا عبدالله بشير

[عادل جلال]

تمام جزاكم الله خير الجزاء استاذنا عبدالله بشير

[elmansyeswa]

بارك الله فيك