(تمت الاجابة) إدراج قائمة فصل من خلال سجل المدرسة

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

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

إخواني الأعزاء الأحباب

أهديكم أجمل وأعطر التحيات

لدي سجل بأسماء التلاميذ بمدرسة ، وأريد استخلاص قائمة بكل فصل على حدة وذلك في ورقة واحة من خلال اختيار الصف والفصل

إليكم طلبي في الملف المرفق....

:fff:

عاشق الإكسيل

School_Record.rar

[عبدالله باقشير]

السلام عليكم

الاخ الفاضل / ياسر خليل---------------حفظه الله

استخدم الكود التالي:

Sub KH_START()
Dim MyRange As Range
Dim R As Integer, C As Integer, M As Integer, O As Integer
Set MyRange = Range("School")
M = 3
O = 3
KH_ClearContents
Application.ScreenUpdating = False
With MyRange
    For R = 1 To .Rows.Count
        If .Cells(R, 1) <> "" Then
            If Val(.Cells(R, 3)) = Val(Range("J3")) And Val(.Cells(R, 4)) = Val(Range("K3")) Then
                If .Cells(R, 5) = "ذكر" Then
                    Cells(M, 1) = M - 2
                    Cells(M, 2) = .Cells(R, 2)
                    Cells(M, 3) = .Cells(R, 6)
                    Cells(M, 4) = .Cells(R, 7)
                    M = M + 1
                End If
                If .Cells(R, 5) = "أنثى" Then
                    Cells(O, 5) = O - 2
                    Cells(O, 6) = .Cells(R, 2)
                    Cells(O, 7) = .Cells(R, 6)
                    Cells(O, 8) = .Cells(R, 7)
                    O = O + 1
                End If
            End If
        End If
    Next R
End With
Application.ScreenUpdating = True
End Sub

تفضل المرفق

School_Record_2009.rar

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

الأخ والأستاذ والمعلم الكبير الجليل العبقري النبيل

صبحك الله بكل خير ووفقك إلى كل خير ورزقك من كل خير

بارك الله فيك على هذا العمل الرائع

لي ملحوظة بسيطة:

أود شرح الكود بشكل مبسط ويس تفصيلي

أود أن أضيف إلى الكود أمر يجعل الصفوف التي بها تلاميذ تحاط بحدود borders من أجل الشكل العام

عنوان الفصل أريده أن يتغير مع تغير الأسماء

أرجو ألا أكون أثقل عليك

بس بصراحة عمل خطير خطير !!!!!!!!!!!!

أنا معجب بيك جداً ، بس يا ريت ماتفهمنيش غلط ، معجب بعلمك مش بحاجة تانية

إني أحبك في الله

عاشق الإكسيل

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

أستاذي ومعلمي / خبور خير

حقاً إنك لرائع ، حقاً إنك لمبدع ، حقاً إنك وإنك ........

أود ااستفسار عن الكود الذي تم عمله : هل يراعي الفرز الأبجدي للأسماء أم لا ؟

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

أنت أنت ولا أحد يباريك

عذراً أيها المنتدى ، فلتقف تقديراً واحتراماً لهذا العالم الفذ الذي لايعرف قدره الكثيرون

عاشق الإكسيل

[عبدالله باقشير]

السلام عليكم

الاخ الفاضل / ياسر خليل---------------حفظه الله

شكرا جزيلا على الكلام الطيب

عملنا الطلب بطريقة اخرى

التصفية المتقدمة بالكود

مع اضافة ما طلبت من الفرز والحدود

عنوان الفصل أريده أن يتغير مع تغير الأسماء

فقد قمت به في الملف السابق

مع شرح مبسط للكود

Sub KH_START()
On Error Resume Next
Dim R As Integer, X As Integer
Application.ScreenUpdating = False
'=================================
' مسح البيانات
KH_ClearContents
'=================================
' فرز School
KH_Sort
'=================================
' تصفية الذكور
Range("معيار").Range("C2") = "ذكر"
Range("School").AdvancedFilter Action:=xlFilterCopy _
    , CriteriaRange:=Range("معيار") _
    , CopyToRange:=Range("الفصل").Columns("B:D"), Unique:=False
'=================================
' تصفية الاناث
Range("معيار").Range("C2") = "أنثى"
Range("School").AdvancedFilter Action:=xlFilterCopy _
    , CriteriaRange:=Range("معيار") _
    , CopyToRange:=Range("الفصل").Columns("F:H"), Unique:=False
'=================================
Range("معيار").Range("C2").ClearContents
'=================================
' ترقيم البيانات
With Range("الفصل")
    For R = 2 To .Rows.Count
        If .Cells(R, 2) <> "" Then .Cells(R, 1) = .Cells(R, 2).Row - 2
        If .Cells(R, 6) <> "" Then .Cells(R, 5) = .Cells(R, 6).Row - 2
    Next R
End With
'=================================
'تسطير الصفوف المحتوية على البيانات
X = Range(Range("A1").CurrentRegion.Address).Rows.Count
With Range("A3:H" & X)
    .Borders.LineStyle = 1
End With
'=================================
Application.ScreenUpdating = True
Range("A3").Select
On Error GoTo 0
End Sub

ودمتم في حفظ الله

School_Record_2009_1.rar

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

أستاذ الأساتذة ومعلم الأجيال

والله يعجز اللسان عن الامتنان بالعرفان .........

لا أملك إلا أن أدعو لك

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

اللهم اجعل عمل أخي خبور خير صالحاً ولوجهك خالصاً

عمل راااااااااااااااااااااائع!!

إني والله أحبك في الله

عاشق الإكسيل

[منير لبيب]

عمل رائع جدا جزاك الله كل خير