البحث في الموقع

بسم الله الرحمن الرحيم هذا ملف به كود لتوزيع طلاب المدارس على الفصول .. اكثر من رائع لسهولته وسرعته لانه يعمل بالمصفوفات صاحب هذا الكود هو المبدع ياسر خليل .. جزاه الله عنا كل خير وبارك في كل واحد يخلص في عمله من اجل رحمة الله تعالى تكوين فصول للمحترم ياســـــــــــــــــــر خليل.rar Option Explicit Sub ClassesListsUsingArrays() 'Author : YasserKhalil 'Release : 30 - 06 - 2017 '------------------------ Dim ws As Worksheet Dim sh As Worksheet Dim arr As Variant Dim temp As Variant Dim i As Long Dim j As Long Dim p As Long Dim n As Long Dim str As String 'لمنع اهتزاز الشاشه Application.ScreenUpdating = False 'متغير اسم ورقه المصدر Set ws = Sheets("بيانات الطلبة") 'متغير اسم ورقه الهدف Set sh = Sheets("فصول") 'مسح بيانات قائمه الفصل sh.Range("B8:F43,H8:L43").ClearContents 'مدى صفوف قائمه الفصل وان تكون عدم مخفيه sh.Rows("8:43").Hidden = False 'خليه القائمه المنسدله لاسماء الفصول str = sh.Range("L1").Value 'مدى صفحة المصدر arr = ws.Range("A7:W" & ws.Range("A" & Rows.Count).End(xlUp).Row).Value ' يقوم بتعيين أبعاد المصفوفة (مصفوفة النتائج) 'لتكون بنفس أبعاد مصفوفة البيانات من حيث عدد الصفوف وعدد الأعمدة ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2)) 'مطابقة القيمة الموجودة في العمود رقم 22 (الذي يحتوي على رقم الفصل) 'مع الشرط في الخلية L1 For i = 1 To UBound(arr, 1) 'متغير رقم عمود الفصل If arr(i, 22) = str Then 'يزيد المتغير P بمقدار واحد p = p + 1 For j = 1 To UBound(arr, 2) temp(p, j) = arr(i, j) Next j 'هذا السطر الذي يتعامل مع القيمة كتاريخ temp(p, 7) = CLng(arr(i, 7)) 'تم وضع رقم تسلسلي للنتائج حسب قيمة المتغير temp(p, j - 1) = p End If Next i 'عند حدوث خطأ انتقل الى الخطوه التاليه On Error Resume Next n = WorksheetFunction.Round(p / 2, 0) 'الرقم 23 الخاص بالمسلسل 'رقم عمود موجود بالمصفوفه 'ولايوجد به بيانات sh.Range("B8").Resize(n, 5).Value = Application.Index(temp, Evaluate("row(1:" & n & ")"), Array(23, 5, 15, 7, 16)) 'الاسم / الديانه/ تاريخ الميلاد / القيد sh.Range("H8").Resize(n, 5).Value = Application.Index(temp, Evaluate("row(" & n + 1 & ":" & p + 1 & ")"), Array(23, 5, 15, 7, 16)) For i = 43 To 8 Step -1 If sh.Cells(i, 2).Value = "" Then sh.Rows(i & ":43").Hidden = True Next i ' اعاده الشاشه كما كانت Application.ScreenUpdating = True End Sub هذا هو تحفة الاكواد للنابغه ياسر خليل