اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


الردود الموصى بها

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

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

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

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

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

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

من الخليه L1

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

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

====

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

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

خط.rar

==========

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

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

تم تعديل بواسطه ناصر سعيد
تنسيق الصفحه
  • Like 1
رابط هذا التعليق
شارك

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

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

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

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

1.JPG

رابط هذا التعليق
شارك

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

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

 

 

إنشاء قوائم الفصول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

 

رابط هذا التعليق
شارك

  • 3 weeks later...
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

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

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

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

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

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

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information