سؤال في سجل فصل بنين ثم بنات حسب خلية

[أبو يوسف النجار]

 

السلام عليكم لخبراء المنتدى

بالملف المرفق أريد من صفحة  ( سجل فصل )  تقسيم الفصول حسب قائمة منسدلة  بالخلية M2 

قائمة سجل فصل  عليا أولاد منفردة  وقائمة سفلى منفردة بنات ومرتبة وهذا حسب بيانات الصفحة الرئيسية السجل 2 وهذا بالطبع حسب التغيير بالخلية M2 

سجل فصل.rar

 

تم تعديل سبتمبر 7, 2016 بواسطه أبو يوسف النجار

[أبو يوسف النجار]

نرجو الرد على السؤال ان أمكن

[ابراهيم الحداد]

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

الصق هذا الكود فى موديول وخصص له زر

Sub Tarhil_Boys()
Range("C11:U46").ClearContents
Range("C55:U89").ClearContents
LR = Sheet1.Cells(Rows.Count, 3).End(xlUp).Row
For R = 9 To LR
If Sheet1.Cells(R, 4) = "ذكر" Then
B = Application.WorksheetFunction.CountIf(Sheet1.Range("F9:F" & R), Cells(2, "M"))
If Cells(2, "M") = Sheet1.Cells(R, 6) Then
B = B + 11
Range("C" & B) = Sheet1.Cells(R, 3)
Range("D" & B) = Sheet1.Cells(R, 27)
Range("E" & B) = Sheet1.Cells(R, 9)
Range("F" & B) = Sheet1.Cells(R, 10)
Range("G" & B) = Sheet1.Cells(R, 11)
Range("H" & B) = Sheet1.Cells(R, 12)
Range("I" & B) = Sheet1.Cells(R, 19)
Range("J" & B) = Sheet1.Cells(R, 5)
Range("K" & B) = Sheet1.Cells(R, 2)
Range("Q" & B) = Sheet1.Cells(R, 14)
Range("T" & B) = Sheet1.Cells(R, 18)
End If
End If
Next
Call Tarhil_Girls
End Sub
Sub Tarhil_Girls()

x = Cells(Rows.Count, 3).End(xlUp).Row - 1
LR = Sheet1.Cells(Rows.Count, 3).End(xlUp).Row
For R = 9 To LR
If Sheet1.Cells(R, 4) = "أنثى" Then
B = Application.WorksheetFunction.CountIf(Sheet1.Range("F9:F" & R), Cells(2, "M"))
If Cells(2, "M") = Sheet1.Cells(R, 6) Then
B = B + 64 - x
Range("C" & B) = Sheet1.Cells(R, 3)
Range("D" & B) = Sheet1.Cells(R, 27)
Range("E" & B) = Sheet1.Cells(R, 9)
Range("F" & B) = Sheet1.Cells(R, 10)
Range("G" & B) = Sheet1.Cells(R, 11)
Range("H" & B) = Sheet1.Cells(R, 12)
Range("I" & B) = Sheet1.Cells(R, 19)
Range("J" & B) = Sheet1.Cells(R, 5)
Range("K" & B) = Sheet1.Cells(R, 2)
Range("Q" & B) = Sheet1.Cells(R, 14)
Range("T" & B) = Sheet1.Cells(R, 18)
End If
End If
Next
End Sub

 

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

أخي الكريم أبو يوسف النجار

قدم لك الأخ زيزو العجوز كود وحل لمشكلتك ولكن نصيحة حاول ألا تستخدم الخلايا المدمجة قدر الإمكان ..

لي سؤال : هل عدد الصفوف التي ستضع فيها البيانات ثابتة أقصد مثلا عدد 35 صف دائماً .. ماذا لو زاد عدد التلاميذ عن 35 طالب ..؟ وماذا لو كان أقل؟

لو كان أقل سيكون هناك عدد صفوف فارغة بين سجل البنين وسجل البنات .. وهل هذا مقبول شكلاً؟

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

أمور لابد من توضيحها ..

[أبو يوسف النجار]

الأستاذ /

زيزو العجوز

 

شكرا جزيلا وبارك الله فيك

حبيبي مستر ياسر

أسئلتك ممتازة وفي الصميم نعم العدد غير ثابت في كل صف والخلايا المدمجة غير ضرورية أرجو من سيادتك التعديل

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

أخي أبو يوسف

حاول أن تساعدنا بوضع التصميم المطلوب وضع شكل النتائج المتوقعة كدليل لنا .. حتى نستطيع تقديم المساعدة

الملف ملفك والتصميم والمخرجات تخصك (فقط حاول ألا تستخدم الخلايا المدمجة قدر الإمكان)

[أبو يوسف النجار]

حاضر يا مستر  / ياسر

[أبو يوسف النجار]

الملف المطلوب و بداخله المطلوب وجزاكم الله خيرا

سجل فصل.rar

[قلم-الاكسل(عبدالعزيز)]

كود ممتاز ايها المبدع زيزو لن اقول العجوز لانه انتقاص من حقك باركتك السماء في عمرك

[أبو يوسف النجار]

تم التعديل على الملف والمطلوب بداخله أرجو الرد

سجل فصل.rar

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

أخي الكريم أبو يوسف ..

أراك أرفقت ملف آخر .. هل يختلف عن السابق وهل هناك جديد ؟

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

تقبل تحياتي

[أبو يوسف النجار]

هو هو نفس الملف والله بس أزلت الخلايا المدمجة

أريد عمل قائمة للفصل على أساس البيانات بصفحة ( السجل 2 ) وتكون القائمة باستدعاء رقم الفصل من القائمة الموجود بخلية M2 بصفحة ( سجل فصل ) وتكون القائمة منقسمة لجزئين جزء خاص بالبنين أعلى الصفحة والزء الثاني للبنات أسفل الصفحة وويكون كل منهما مسلسل من 1 إلى 2 إلى 3 حتى 40 مثلا ولا يكون العدد ثابت لأن هناك فصول تزيد عن 30 مثلا وفصول تقل عن 30 ولكن الأقصى 40

طلب بديل : وإن لم يمكن الحل السابق يمكن بطريقة التصفية مرتين اختر الفصل ثم النوع فتظهر القائمة

 

سجل فصل.rar

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

أخى الفاضل / أبو يوسف ... السلام عليكم

هذا حل بسيط إن شاء الله للمطلوب من الملف

أجريت بعض التنسيقات اللازمة على ورقة العمل لتبدو على الشكل المطلوب

قمت بادخال المعادلات المطلوبة لذلك وشغالة إن شاء الله ـ

أدرجت ورقة عمل جديدة باسم ( Mohamed El_Desoky) فيها المطلوب ـ أرجو تجربتها والرد عليها

تقبل تحياتى

 

 

سجل فصل.xlsm ـ محمد الدسوقى.rar

[أبو يوسف النجار]

أستاذ / محمد الدسوقى        بارك الله فيك

الملف هو المطلوب أعزك الله وجزاك الله خير على تعبك

 

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

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

أثناء تقديم الحل كنت أقوم بكتابة كود .. يقوم بعمل اللازم أما التنسيقات فعادية يمكنك تنسيق ورقة العمل كما تريد ، كما يمكنك استخدام الخلايا المدمجة في العناوين لا مشكلة في ذلك)

سيقوم الكود بعمل اللازم وترك 5 صفوف فارغة بين سجل البنون وسجل البنات ...

أرجو أن يفي بالغرض إن شاء الله

هذا هو الكود المستخدم

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

Sub Lists_Using_Arrays()
'Author  : YasserKhalil
'Release : 10 - 09 - 2016
'------------------------
    Dim Ws As Worksheet, Sh As Worksheet, sSheet As Worksheet
    Dim Crit As String
    Dim I As Long, J As Long, P As Long
    Dim Lr As Long, Last As Long
    Dim Arr, Temp

    Application.ScreenUpdating = False
        Set Ws = Sheets("Data"): Set Sh = Sheets("Lists")
        Crit = Sh.Range("M2").Value
        P = 1
    
        Sh.Rows("10:" & Rows.Count).EntireRow.Delete
        Sh.Range("K5:M5").ClearContents
        If Crit = "" Or Application.WorksheetFunction.CountIf(Ws.Range("F:F"), Crit) = 0 Then MsgBox "Fill The Cell M2", vbExclamation: Exit Sub
        Arr = Ws.Range("A9:AA" & Ws.Cells(Rows.Count, 1).End(xlUp).Row).Value
        ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2) - 5)
    
        For I = 1 To UBound(Arr, 1)
            If Arr(I, 6) = Crit Then
                Temp(P, 1) = P: Temp(P, 2) = Arr(I, 3): Temp(P, 3) = Arr(I, 27)
                For J = 4 To 7
                    Temp(P, J) = Arr(I, J + 5)
                Next J
                Temp(P, 8) = Arr(I, 19): Temp(P, 9) = Arr(I, 5): Temp(P, 10) = Arr(I, 2)
                For J = 16 To 18
                    Temp(P, J) = Arr(I, J - 2)
                Next J
                Temp(P, 19) = Arr(I, 18): Temp(P, 20) = P
                Temp(P, 21) = Arr(I, 6): Temp(P, 22) = Arr(I, 4)
                P = P + 1
            End If
        Next I
    
        Sheets.Add After:=Sheets(Sheets.Count)
        Set sSheet = ActiveSheet
    
        With sSheet
            .Columns("U:U").NumberFormat = "@"
            .Range("U1") = "Class": .Range("V1") = "Gender"
            .Range("A2").Resize(P, UBound(Temp, 2)).Value = Temp
            Lr = .Cells(Rows.Count, 1).End(xlUp).Row + 1
            .Range("A2:A" & Lr).Formula = "=SUBTOTAL(103,$B$2:B2)"
    
            .Range("A1:V1").AutoFilter Field:=22, Criteria1:="ذكر"
            .Range("A2:T" & Lr - 1).SpecialCells(xlCellTypeVisible).Copy
            Sh.Range("B11").PasteSpecial xlPasteValues
    
            Last = Sh.Cells(Rows.Count, 2).End(xlUp).Row + 6
            Sh.Rows("4:9").Copy Sh.Range("A" & Last)
            
            .Range("A1:V1").AutoFilter Field:=22, Criteria1:="أنثى"
            .Range("A2:T" & Lr - 1).SpecialCells(xlCellTypeVisible).Copy
            Sh.Range("B" & Last + 7).PasteSpecial xlPasteValues
        End With
    
        With Sh
            .Range("K5") = .Range("M2")
            .Range("L5") = "بنون"
            .Range("M5") = Application.WorksheetFunction.CountA(.Range("B11:B" & Last - 6))
    
            .Range("K" & Last + 1) = .Range("M2")
            .Range("L" & Last + 1) = "بنات"
            .Range("M" & Last + 1) = Application.WorksheetFunction.CountA(.Range("B" & Last + 7 & ":B" & .Cells(Rows.Count, 2).End(xlUp).Row))
            
            .Range("B11:U" & Last - 6).Borders.Value = 1
            .Range("B" & Last + 7 & ":U" & .Cells(Rows.Count, 2).End(xlUp).Row).Borders.Value = 1
        End With
        
        Application.DisplayAlerts = False
            sSheet.Delete
        Application.DisplayAlerts = True
        
        Application.Goto Sh.Range("M2")
        Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

تحميل الملف المرفق من هنا

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

أخى الفاضل / ياسر

تسلم دماغك .. حل جميل و أكثر من رائع ... جعلك الله عنوانًا مميزًا فى هذا الصرح التعليمى العظيم

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

[أبو يوسف النجار]

مستر / ياسر

تشرفت بزيارتك للموضوع  كالعادة تسلم وتسلم دماغك ( ربنا ما يحرمنا منك )

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

تم تعديل سبتمبر 10, 2016 بواسطه أبو يوسف النجار