تكوين فصول للمحترم محمود الشريف

[ناصر سعيد]

تكوين قوائم فصول المدرسة

هذا الملف من ابداع المحترم محمود الشريف  .. وهو خاص بتكوين قوائم للفصول المدرسيه .. ولاأروع منه

جزاه الله عنا كل خير وبارك له

طريقه العمل مع الملف

اضغط زر القيم الفريده ليجلب اسماء الفصول مرتبه

اختر بعد ذلك الفصل الذي تريد استخراج قائمته

من الخليه L1

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

تكوين فصول للمحترم محمود الشريف.rar

====

خطوط رائعه يمكن ان تضاف الى الجهاز لتجميل قائمه الفصل

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

خط.rar

==========

رابط لخطوط غايه في الجمال والروعه

https://up.top4top.net/downloadf-3206k2ma1-rar.html

تم تعديل أكتوبر 20, 2017 بواسطه ناصر سعيد
تنسيق الصفحه

[صـدّيـق]

شكرا لك وللأستاذ محمود الشريف

ولكن الملف لا يشتغل عندي، تظهرالرسالة التي بالصورة 

يتم اصلاحه بالضغط على "yes" وكن تختفي جميع الاكود 

لا ادري ان كانت المشكلة عندي فقط 

[احمد بدره]

تسلم الأنامل

[ناصر سعيد]

اخي صديق

المشكله عندك .. جزاك الله خيرا

اخي

ahmedkamelelsay

ربنا يبارك فيك ويارب تكون استفدت

 

[ناصر سعيد]

 

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

 

[ناصر سعيد]

 

[ناصر سعيد]

الاستاذ محمود الشريف جزاه الله خيرا

شرح الكود الخاص به لتوزيع الفصول وهذا هو المرفق

 

 

إنشاء قوائم الفصول1.rar

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

Sub MZM_START()
' الاعلان عن المتغيرات وعددهم خمسة
Dim MyRange As Range
Dim R As Integer, C As Integer, M As Integer, Y As Integer, t As Integer
'تعريف مدى البيانات بشيت بيانات الطلبة الذى يتم جلب البيانات منه
'='بيانات الطلبة'!$A$10:$AK$1009
'بإسم school
Set MyRange = Range("School")
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False

'=================================
' مسح البيانات
'استدعاء كود مسح البيانات بشيت قوائم الفصول
'لإستقبال البيانات الجديدة وهذا المدى تم تحديده داخل  الكود
'("B11:L60")

MZM_ClearContents
'=================================
' فرز School
'استدعاء كود الفرز للبيانات بشيت بيانات الطلبة

MZM_Sort
'=================================
'تم وضع شرط إضافة نصف عدد الفصل بالخلية
'E2
'وفى حال عدم وجود بيانات بتلك الخلية يتم التنفيذ بناء على شرط افتراضى
'أن نصف عدد الفصل يساوى 50 طالب
'نلاحظ أنه فى حالة عدم ادخال رقم بهذه الخلية سيتم جلب البيانات داخل قائمة واحدة
'ولن يتم قسمة عدد إجمالى طلاب الفصل على قائمتين

If IsEmpty(Range("E2")) Or IsNumeric(Range("E2")) = False Then t = 50 Else t = Range("E2").Value
'تحديد صف رؤوس الجدول بالصف العاشر
C = 10
With MyRange
'بداية حلقة تكرارية لجلب البيانات المطلوبة مع وضع شروط لها كالتالي

    For R = 1 To .Rows.Count
        If .Cells(R, 2) <> "" Then
           ' اضافة شرط ان العمود الرابع بشيت بيانات الطلبة يتوافق مع رقم الفصل المطلوب بالخلية
           'L2
           'الموجود بها قائمة الفصول بشيت قوائم الفصول

            If .Cells(R, 4).Text = Range("L2").Text Then
                'وضع شرط فى حال توافر بيانات بالخلية
                'J2
                'القائمة المنسدلة الخاصة بالنوع ذكر أم أنثى يعمل الكود على أساسها
                'فى حال عدم توافر بيانات بها يستمر الكود فى عمله
                'شرط أن تتوافق الخلية مع العمود رقم 18 بالشيت الرئيسى
                If Range("J2").Text = "" Then GoTo 1
                If .Cells(R, 18).Text = Range("J2").Text Then
1               If M >= t Then Y = 6: M = 0
                    M = M + 1
                   'تم اضافة شرط خاص بتنسيق الجدول حسب تواجد رؤوس الأعمدة بشيت قوائم الفصول
                   'نقول فيه أن
                   'Y = 6
                   'أى أن عدد أعمدة كل قائمة من القائمتين بشيت قوائم الفصول والتى يتم جلب بيانات فيها عددها 6 أعمدة
                    If Y = 6 Then Cells(C + M, Y + 2) = M + t Else Cells(C + M, Y + 2) = M
                   'العمود الثالث بشيت قوائم الفصول يتم جلب البيانات إليه من العمود الثاني بشيت بيانات الطلبة
                   'مع ملاحظة أنه حسب الشروط فى حالة توافق شرط نصف عدد الطلاب حسب الخلية
                   'E2
                   'يتم قسمة عدد الطلاب على القائمتين بحيث أن العمود الثالث بشيت قوائم الفصول سيتم
                   'استكمال البيانات بالعمود التاسع بشيت قوائم الفصول
                   'وهذا ما تعنية
                   'Y + 3
                   'وهكذا فى باقي الأعمدة
                    Cells(C + M, Y + 3) = .Cells(R, 2)
                   'العمود الرابع بشيت قوائم الفصول يتم جلب البيانات إليه من العمود ال 17 بشيت بيانات الطلبة
                    Cells(C + M, Y + 4) = .Cells(R, 17)
                   'العمود الخامس بشيت قوائم الفصول يتم جلب البيانات إليه من العمود ال 11 بشيت بيانات الطلبة
                    Cells(C + M, Y + 5) = .Cells(R, 11)
                   'العمود السادس بشيت قوائم الفصول يتم جلب البيانات إليه من العمود ال 7 بشيت بيانات الطلبة
                    Cells(C + M, Y + 6) = .Cells(R, 7)
                End If
            End If
        End If
    Next R
End With
'=================================
'اخفاء الصفوف المتبقية من التعيين
If t = 50 Then GoTo 2
With Range("B11:L60")
'يتم اخفاء الصفوف الفارغة والتى زادت عن نصف عدد الفصل من الطلاب والذى تم تحديده بـ 50
    .Offset(t, 0).Resize(50 - t).EntireRow.Hidden = True
End With
'=================================
    Application.Calculation = xlCalculationAutomatic

2 Application.ScreenUpdating = True
End Sub
Sub MZM_ClearContents()
'يتم مسح هذا المدى لتجهيز الشيت لإستقبال بيانات جديدة
'مع إظهار الصفوف التى تم إخفاؤها
With Range("B11:L60")
    .ClearContents
   .EntireRow.Hidden = False
End With
End Sub
Sub MZM_Sort()
'عملية فرز للمدى المحدد بإسم
'School
'بشيت بيانات الطلبة بالعمودين
'A , B
With Range("School")
    .Sort .Columns("A:A"), xlAscending
    .Sort .Columns("B:B"), xlDescending
End With
End Sub

 

[ناصر سعيد]

Sub SortData()

    Dim lr As Long

    lr = Range("E" & Rows.Count).End(xlUp).Row

    For Each Cell In ActiveSheet.Range("E7:E" & lr)

        Cell.Value = Application.WorksheetFunction.Trim(Cell.Value)

    Next

    Range("B7:S" & lr).Sort Key1:=Range("F7:F" & lr), Order1:=2, Key2:=Range("E7:E" & lr), Order2:=1, Header:=xlNo

End Sub

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

ولكن به اضافه مفيده

وهي ازاله المسافات من بين الاسماء

مما تعطي فرزا دقيقا

للمحترم الغالي ياسر العربي