اللجان بطريقه المصفوفات السريعه

[ناصر سعيد]

هذا عمل رائع للمحترم ياسر العربي ..

خاص بتوزيع الطلاب على اللجان بطريقه المصفوفات السريعه

ولكنه ياتي بلجنه واحده في الصفحه

فمن من الافذاذ

الذي يجعل هذا الكود يوزع اللجان على نصفي الورقه

Sub Yasser()
    Dim myarr()
    Dim a, b, c, m, n, o
    a = Sheets("كشوف المناداة").Range("E2")
    b = Application.WorksheetFunction.Count(Sheets("بيانات الطلبة").Range("B7:B2000"))
    z = b / a
    n = Int(z)
    m = Round((z - n) * a, 1)
    Range("B9:F9").ClearContents
     Range("B10:F" & Cells(Rows.Count, 2).End(xlUp).Row + 2).Clear
    myarr() = Sheets("بيانات الطلبة").Range("B7:P" & Sheets("بيانات الطلبة").Cells(Rows.Count, 2).End(xlUp).Row).Value
    ReDim y(1 To UBound(myarr, 1) + (a * n), 1 To 5)
    For x = LBound(myarr) To UBound(myarr)
        rw = rw + 1
        rr = rr + 1
        y(rw, 1) = rr: y(rw, 2) = myarr(x, 1)
        y(rw, 3) = myarr(x, 4): y(rw, 4) = myarr(x, 14)
        y(rw, 5) = myarr(x, 15)
        If m > 0 And rr = n + 1 Then
            m = m - 1
            rr = 0
            rw = rw + 8
        ElseIf m <= 0 And rr = n Then
            rr = 0
            rw = rw + 8
        End If
    Next x
    Range("B9:F9").AutoFill Destination:=Range("B9:F" & b + (a * 8) + 8), Type:=xlFillDefault
    If rw > 0 Then Cells(Rows.Count, 2).End(xlUp)(2, 1).Resize(rw, 5).Value = y()
    Range("T3:X10").Copy
    Range("B9:F" & Cells(Rows.Count, 2).End(xlUp).Row + 8).SpecialCells(xlCellTypeBlanks).Select
    ActiveSheet.Paste
    Range("B" & Cells(Rows.Count, 2).End(xlUp).Row - 6 & ":F" & Cells(Rows.Count, 2).End(xlUp).Row + 6).Clear
88 End Sub

كتبها الله لكم في كفة حسناتكم

توزيع اللجان للعبقري ياسر العربي.rar

[ابراهيم الحداد]

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

اخى الكريم   انظر الى هذا الملف

 

قوائم اللجان.rar

[ناصر سعيد]

اخي الكريم الاستاذ المحترم زيزو

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

ان شاء الله سيكون افضل واول كود بالمصفوفات لتوزيع اللجان على مستوى المنتديات

بارك الله فيك

الكود يعمل جيدا وسريع ولكنه ياتي فقط باللجنتين الاوليين فقط

ثانيا لو تم توزيع عدد كل لجنه اوتوماتيك بمعنى ها اكتب عدد اللجان المطلوبه والكود يوزعهم بالتساوي

ربنا يبارك فيك ... يارب

================

كودكم الرائع بيقف عند عدد طلاب اللجنه 22 طالب فقط

يعني لو كتبت عدد طلاب لجنه 25 مثلا وشوف لاتمتد التسطيره بالعدد المطلوب

يحفظكم الخالق

 

[ابراهيم الحداد]

اخى الكريم الاستاذ ناصر

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

تم زيادة نطاق اللجنة حتى 26 طالب

يجب تعبئة جدول توزيع الطلاب على اللجان

يتم اختيار رقم اللجنة من القائمة المنسدلة فى الخلية "D4"

فتتغير تلقائيا اللجنة المجاورة ختى نفاذ عدد اللجان الموزعة

اليك الملف بعد التعديل

تقبل فائق تحياتى

 

قوائم اللجان.rar

تم تعديل مايو 1, 2017 بواسطه زيزو العجوز

[ناصر سعيد]

يجزيك الله كل خير وبارك في صحتك واهلك ومالك اخي الكريم استاذ زيزو .. يارب

نرجو شرح اسطره من فضلك

لانني عندما حاولت نقل الكود في ملف اخر لم يعمل معي الكود

ثانيا هل بطريقه او باخرى نستطيع عند كتابه عدد اللجان المطلوبه يتم ملأ جدول الاعداد الموجود  مادام شرط وجود هذا الجدول

[ناصر سعيد]

يجزيك الله كل خير

وبارك في صحتك واهلك ومالك

اخي الكريم استاذ زيزو .. يارب

[ناصر سعيد]

نرجو شرح اسطرالكود  ..  من فضلك

[ابراهيم الحداد]

اخى الكريم الاستاذ ناصر

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

اليك شرح الكود كما طلبت عسى الله ان اكون قد وفقت

وفقنا الله واياكم لما يحب ويرضى

Sub LClasses()
  الاعلان عن المتغيرات '
Dim ws As Worksheet, sh As Worksheet
Dim Arr As Variant, Temp As Variant, Temp2 As Variant
Dim LR As Long, i As Long, j As Long, f As Long, p As Long, q As Long
Dim x, y, a, b, c, d, xx, yy
Dim c1, c2, c3, c4
Dim d1, d2, d3, d4
Set ws = ThisWorkbook.Sheets("بيانات الطلبة")   
تعريف الشيت الاول وهو مصدر البيانت'  
Set sh = ThisWorkbook.Sheets("كشوف المناداة")   
تعريف الشيت الثانى قوائم اللجان'
LR = ws.Range("E" & Rows.Count).End(xlUp).Row + 6  
آخر صف فى الشيت الاول'
Arr = ws.Range("A7:P" & LR).Value   
تحديد نطاق المصفوفة المصدر'
ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))  
اعادة تعين المصفوفة الثانية الخاصة بكشف اللجان الاول'
ReDim Temp2(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))  
عادة تعين المصفوفة الثانية الخاصة بكشف اللجان الثانى'
sh.Range("B9:N34").ClearContents   
مسح اللجان قبل تفريغ اى بيانات جديدة'
a = sh.Range("D7").Value  
رقم اللجنة الاولى'
b = sh.Range("L7").Value 
رقم اللجنة الثانية '
On Error Resume Next
c = WorksheetFunction.VLookup(a, sh.Range("AE3:AF" & sh.Range("AF" & Rows.Count).End(xlUp).Row), 2, 0)  
التأكد من عدد اللجان للقائمة الاولى'
d = WorksheetFunction.VLookup(b, sh.Range("AE3:AF" & sh.Range("AF" & Rows.Count).End(xlUp).Row), 2, 0)  
التأكد من عدد اللجان للقائمة االثانية''
x = (a - 1) * c + 1: xx = a * c  
 التعرف على اول و آخر طالب فى الكشف الاول'
y = (b - 1) * d + 1: yy = b * d  
التعرف على اول و آخر طالب فى الكشف االثانى'
0
For i = 1 To UBound(Arr, 1)  
تنبيه الكود بالصفوف التى سوف يتم العمل عليها فى المصفوفة الام'
If i >= x And i <= xx Then  
شرط الصفوف المطلوبة من المصفوفة الام لكل لجنة '
p = p + 1   
العد حسب الشرط الموضح بعاليه'
For j = 1 To 4  
عدد الاعمدة المطلوبة من المصفوفة الام للمصفوفة الجديدة والتى تخص اللجنة الاولى ( التى هى على يمين الورقة )'
Temp(p, j) = Arr(i, Choose(j, 2, 5, 15, 16)) 
تحديد المصفوفة الجديد او المطلوبة واختيار اعمد بعينها '
sh.Cells(p + 8, 2) = p 
ترقيم الطلاب فى اللجنة   '
Next
End If
If i >= y And i <= yy Then  
الشرط الثانى وهو الذى يخص اللجنة الثانية - باقى الشرح نفس الشرح السابق'
q = q + 1
For f = 1 To 4  '
Temp2(q, f) = Arr(i, Choose(f, 2, 5, 15, 16))  
Cells(q + 8, 10) = q  '
Next
End If
Next
If p > 0 Then sh.Range("C9").Resize(p, j).Value = Temp  
اتصدير المصفوفة الجديدة الاولى كما رتب لها'
If q > 0 Then sh.Range("K9").Resize(q, f).Value = Temp2  
اتصدير المصفوفة الجديدة الثانية كما رتب لها'
  الخطوات بالاسفل اعتقد انها واضحة تماما وهى احصيات '''
c1 = WorksheetFunction.CountIf(sh.Range("E9:E34"), "*" & "مسلم" & "*")  
c2 = WorksheetFunction.CountIf(sh.Range("E9:E34"), "*" & "مسيحى" & "*")  
c3 = WorksheetFunction.CountIf(sh.Range("F9:F34"), "*" & "منقول" & "*")  
c4 = WorksheetFunction.CountIf(sh.Range("F9:F34"), "*" & "باق" & "*")  

d1 = WorksheetFunction.CountIf(sh.Range("M9:M34"), "*" & "مسلم" & "*")  
d2 = WorksheetFunction.CountIf(sh.Range("M9:M34"), "*" & "مسيحى" & "*")
d3 = WorksheetFunction.CountIf(sh.Range("N9:N34"), "*" & "منقول" & "*")
d4 = WorksheetFunction.CountIf(sh.Range("N9:N34"), "*" & "باق" & "*")
   خلايا نتائج الاحصائيات'''
sh.Range("F3") = c    
sh.Range("F6") = c1
sh.Range("F7") = c2
sh.Range("F4") = c3
sh.Range("F5") = c4

sh.Range("N3") = d
sh.Range("N6") = d1
sh.Range("N7") = d2
sh.Range("N4") = d3
sh.Range("N5") = d4


End Sub

 

[ناصر سعيد]

كتبها الله لك في كفة حسناتك ... يارب

شكرا لك استاذ زيزو