قوائم الفصول قوائم الفصول

[محمد أبوعبدالله]

بسم الله الرحمن الرحيم

الاخوة الكرام

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

ارجو من الاخوة الكرام المساعدة في الملف المرفق وهو خاص بقوائم الفصول

في الورقة 2 توجد قائمة في الحقل J1 اريد عند اختيار الصف من هذه القائمة يتم استدعاء البيانات من الورقة 1 حسب الصف

ارجو ان تكون الفكرة واضجة ولكم جزيل الشكر

تحياتي

Book1.rar

[ياسر خليل أبو البراء]

وعليكم السلام أخي الكريم محمد أبو عبد الله

1 - قم بالدخول للرابط التالي لنسخ الكود بالكامل

2- افتح المصنف الخاص بك واضغط Alt + F11 للدخول لمحرر الأكواد

3- من قائمة Insert أدرج موديول جديد والصق فيه ما قمت بنسخه من أكواد

4- آخر جزء في الكود سيتم نقله إلى حدث ورقة العمل "ورقة2" .. لذا قم بتحديد آخر جزء في الكود ثم اضغط Ctrl + X لقص هذا الجزء ووضعه في مكان آخر

5- من نافذة المشروع انقر دبل كليك على ورقة العمل "ورقة2" لتضع الكود الذي تم قصه إلى هذا الموديول

6- اذهب لورقة العمل المسماة "ورقة2" واختر الفصل المطلوب إعداد قائمة له .. من الخلية J1

رابط الكود من هنا

 

[الأستاذ / محمد الدسوقى]

أخى الفاضل  الأستاذ  / محمد أبو عبد الله

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

أعجبنى كثيرًا الحل الذى قدمه المبدع  دائما الأستاذ الفاضل / ياسر خليل أبو البراء ـ لكيفية عمل قوائم الفصول باستخدام الأكواد

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

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

قوائم الفصول باستخدام المعادلاات ـ محمد الدسوقى.rar

[ياسر خليل أبو البراء]

بارك الله فيك أخي الكريم محمد الدسوقي على هذه الإبداعات .. ولكن لاحظ أنك اعتمدت أن عدد الطلاب ثابت وهو 60 طالب لكل فصل

جرب تغير في البيانات الرئيسية لبعض الطلاب وليكن 1/1 .. اختار شوية من الفصول التانية وخليهم 1/1 .. وشوف القوائم هتكون مضبوطة أم لا

تقبل تحياتي

 

[محمد أبوعبدالله]

Book1.rar

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

اشكركم اخواني جزيل الشكر

استاذي الفاضل ياسر مرفق الملف بعد اضافة الكود وتنفيذ تعليمات حضرتك ولكن للاسف لا يقوم بالفترة حسب القائمة برجاء توضيخ اين المشكلة بالضبط

=========

استاذي الفاضل محمد الدسوقي اشكرك جزيل الشكر

ولكن ايضا تظهر مشكلة عند اختيار صف برجاء الاطلاع على الصورة

 

[ياسر خليل أبو البراء]

وعليكم السلام أخي محمد

ملفك يعمل بشكل ممتاز ولا مشكلة فيه عندي

حاول توضح ما هي رسالة الخطأ التي تظهر لديك؟ انقر على كلمة Debug ثم انسخ سطر المشكلة إلى المشاركة أو صور المشكلة لتتضح الصورة

الخطوات التي قمت بها صحيحة إن شاء الله والكود يعمل وإليك الدليل

 

2016-09-08_07-06-01.rar

[محمد أبوعبدالله]

السلام عليكم

اخي العزيز ياسر

المسكلة ليست في الاوامر ولكن عند الاختيار من القائمة لا يتم الفلترة ويتم استدعاء جميع البيانات

علما باني استخدم اكسيل 2003

دمت بكل خير

تحياتي

 

[الأستاذ / محمد الدسوقى]

أستاذى الفاضل / ياسر    ......   السلام عليكم ورحمة الله وبركاته

فى هذا الملف اعتمدت على عدد كل فصل 60 تلميذا ، ولكن يمكن عمل بعض التعديلات البسيطة ليوافق الفصل أى عدد وليكن 80 وهذا غير معقول لأن يكون الفصل بهذا العدد

ومهما يكن يمكن عمل ذلك واستخدام خاصية شطر القائمة إلى قائمتين متساويتين تقريبا ، وهذا ما فهمته من قصدك فى التعليق السابق

تقبل وافر تحياتى واحترامى

 

 

[ياسر خليل أبو البراء]

11 ساعات مضت, محمد ابوعبد الله said:

السلام عليكم

اخي العزيز ياسر

المسكلة ليست في الاوامر ولكن عند الاختيار من القائمة لا يتم الفلترة ويتم استدعاء جميع البيانات

علما باني استخدم اكسيل 2003

دمت بكل خير

تحياتي

 

لم تحدد المشكلة ..أنا لم أعمل على 2003 منذ 2007 ..

يرجى وضع صورة للمشكلة وتحديد السطر الذي به المشكلة لكي أحاول تعديل الكود بما يتلائم مع نسخة الأوفيس لديك

 

يبدو أنني مخطيء وعند مراجعة المشاركة وجدت أنه لا مشكلة ولكن لا تحدث عملية الفلترة بشكل صحيح .. لا أدري بالضبط ما المشكلة في 2003 التي تمنع عملية الفلترة وقد رأيت بنفسك في الفيديو أنه يعمل لدي بشكل صحيح

عموماً جرب الحل بالمعادلات الذي قدمه لنا أخونا محمد الدسوقي فهو حل جيد ويفي بالغرض ..إن شاء الله

 

* خطرت لي فكرة ربما تفيد في الموضوع .. سجل بالماكرو عملية فلترة لنرى الاختلاف في أسطر الفلترة هنا وهنا !! لعل وعسى

أو خيار آخر قم بتحديث الأوفيس لنسخة 2013 أو 2016 ... دعونا نواكب التطور (هذا شعاري منذ البداية)

[محمد أبوعبدالله]

اشكركم اخواني الكرام جزيل الشكر وكل عام وانتم بخير

استاذي الفاضل ياسر تم تشغيل الملف على اكسيل 2013 وانتهت المشكلة والحمد لله فهل يمكن تشغيل الملف على اكسيل 2003

استاذي الفاضل محمد الدسوقي نفس الموضوع ايضا على اكسيل 2013 انتهت المشكلة فهل يمكن تشغيله على اكسيل 2003

ودمتم بكل خير

وكل عام وانتم بخير

تحياتي

 

 

[كعبلاوى]

كل عام والامة الاسلامية والعربية بخير

هذا الملف الذى اعمل به داخل مدرستى الملف من تنفيذ احد اساتذتى فى الموقع

قمت بادخال بعض الاضافات عليه وحذفت بعض الاشياء التى لا تعمل ويمكن تنفيذها بطرق اخرى 

 اتمنى ان ينال رضاكم 

برنامج كعبلاوى لقوائم الفصول.rar

[ناصر سعيد]

'https://www.officena.net/ib/topic/71642-*
'=========================================

Sub Classes_Lists()
'Author  : YasserKhalil
'Release : 07 - 09 - 2016
'------------------------
    Dim shSource        As Worksheet
    Dim shTarget        As Worksheet
    Dim rList           As Range
    Dim rListA          As Range
    Dim rListB          As Range
    Dim strCrit         As Range
    Dim colNum          As Integer
    Dim Lr              As Long
    Dim hCount          As Long
    Dim tCount          As Long

    '===========================================================
    'رقم أول صف للبيانات وهو صف العناوين
    Const firstRow As Integer = 1

    '[A] رقم أول عمود للبيانات ، الرقم 1 يمثل العمود الأول
    Const colFirst As Integer = 1

    '[D] رقم آخر عمود للبيانات ، الرقم 4 يمثل العمود الرابع
    Const colLast As Integer = 4

    '[A:D] رقم الحقل المراد فلترته داخل النطاق ، فالرقم 4 يمثل الحقل الرابع في النطاق
    Const iCol As Integer = 4

    'الورقة المصدر التي تحتوي على البيانات
    Set shSource = Sheets("ورقة1")

    'الورقة الهدف التي ستوضع فيها النتائج
    Set shTarget = Sheets("ورقة2")

    'عنوان أول خلية ستوضع فيها النتائج في الورقة الهدف
    Set rListA = shTarget.Range("A2")

    'الخلية التي تحتوي على شرط الفلترة للبيانات
    Set strCrit = shTarget.Range("J1")
    '===========================================================

    If IsEmpty(strCrit) Then MsgBox "The Criteria Cell Is Empty", vbExclamation: Exit Sub
    colNum = (colLast - colFirst) + 1
    Set rListB = rListA.Offset(, colNum)

    SpeedUp
        shSource.Copy After:=Sheets(Sheets.Count)
        ActiveSheet.Name = "Temp"
        Set shSource = Sheets("Temp")
    
        With shSource
            shTarget.Range(shTarget.Columns(colFirst), shTarget.Columns(colLast)).Resize(, colNum * 2).Clear
            .Range(.Cells(firstRow, colFirst), .Cells(firstRow, colLast)).Copy rListA.Offset(-1)
            .Range(.Cells(firstRow, colFirst), .Cells(firstRow, colLast)).Copy rListA.Offset(-1, colNum)
    
            .Range(.Cells(firstRow, colFirst), .Cells(firstRow, colLast)).AutoFilter Field:=iCol, Criteria1:=strCrit
            .Range(.Columns(colFirst), .Columns(colLast)).Copy .Cells(firstRow, colLast + 5)
            .AutoFilterMode = False
            Lr = .Cells(Rows.Count, colLast + 5).End(xlUp).Row
            .Range(.Cells(firstRow + 1, colLast + 5), .Cells(Lr, colLast + 5)).Formula = "=ROW()-" & firstRow & ""
    
            Set rList = .Range(.Cells(firstRow + 1, colLast + 5), .Cells(Lr, colLast + 5))
            tCount = rList.Cells.Count
            hCount = Application.RoundUp(tCount / 2, 0)
            rListA.Resize(Rows.Count - (rListA.Row), (colNum * 2)).ClearContents
            rListA.Resize(hCount, colNum).Value = Range(rList(1).Address(External:=True) & ":" & rList(hCount).Address(External:=True)).Resize(hCount, colNum).Value
            rListB.Resize(tCount - hCount, colNum).Value = Range(rList(hCount + 1).Address(External:=True) & ":" & rList(tCount).Address(External:=True)).Resize(hCount, colNum).Value
    
            .Delete
        End With
    
        With rListA.Offset(-1).CurrentRegion
            .ReadingOrder = xlRTL
            .Font.Name = "Arial"
            .Font.Size = 11
            .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter
            .RowHeight = 19
            .Borders.Value = 1
        End With
    
        With rListA.Offset(-1).Resize(, colNum * 2)
            .Font.Size = 14: .Interior.Color = vbCyan: .RowHeight = 25
        End With
        Application.Goto strCrit
    SpeedDown
End Sub

Function SpeedUp()
    With Application
        .DisplayAlerts = False
        .Calculation = xlManual
        .ScreenUpdating = False
        .DisplayStatusBar = False
        .EnableEvents = False
    End With
End Function

Function SpeedDown()
    With Application
        .CutCopyMode = False
        .DisplayAlerts = True
        .Calculation = xlAutomatic
        .ScreenUpdating = True
        .DisplayStatusBar = True
        .EnableEvents = True
    End With
End Function

'**************************************************************

'يوضع الكود التالي في حدث ورقة العمل التي ستظهر فيها النتائج
'وهي ورقة العمل المخصصة لتجهيز قوائم الفصول
'------------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$J$1" Then
        Call Classes_Lists
    End If
End Sub

جزاك الله كل خير استاذ ياسر خليل

الكود يعمل جيدا على اكسبل 2010 ولكن

نريد ترك عده صفوف راس  وتحتها 3 صفوف لتاخذ بعض المعلومات مثل شؤن طلاب  ... رئيس شئون طلاب ... مدير المدرسه

لو تم تفعيله على هذا الملف سيكون سريعا جدا ورائعا كتبه الله في كفة حسناتك استاذ ياسر

==========

سأرفق ملفا ان شاء الله

[ناصر سعيد]

==========

 

قوائم الفصــول.rar

=*=*=*=*=*=*=*=*=

هذا الكود من الروائع التي يجب الاهتمام بها