محتاج تصحيح كود قوائم الفصول

[2saad]

السلام الله عليكم ورحمته وبركاته ..اخواني أعضاء المنتدي الكرام

محتاج تعديل علي كود الملف المرفق بحيث ينقل البيانات من شيت (بيانات ) الي شيت فصول بطريقة مطاطية بحيث تقفل القائمة عند آخر سطر بيانات

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

انتبه من فضلك .. مشاركة مكررة فقد تــــم بالفعل حذف المشاركة الأخرى

قوائم.xlsm

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

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

اخى الكريم جرب هذا الكود ..لو لك طلبات غير و اضحة فى مشاركتك الاولى يرجى توضيحها

لآن الملف البببانات فيه غير كافية سواء من ناحية عدد الفصل الواحد او النوع

بحيث نتمكن من اختبار الكود جيدا ..ارجو الاجابة بوضوح بعد التجربة ..اليك الكود

Sub AdClass()
Const K1 = "ذكر": Const K2 = ""
Dim Sh As Worksheet, ws As Worksheet
Dim Arr As Variant, Tmp As Variant
Dim LR As Long, p As Long, i As Long, ii As Long, j As Long
Dim Fsl As String, C As Range
Application.ScreenUpdating = False
Set Sh = Sheets("بيانات"): Set ws = Sheets("فصول")
ws.Range("D10:I49") = "": ws.Range("K10:P49") = ""
LR = Sh.Range("E" & Rows.Count).End(3).Row
Fsl = ws.Range("O7").Value
For Each C In Sh.Range("J10:J" & LR)
If C.Value = Fsl Then
p = p + 1
If p <= 40 Then
On Error Resume Next
ws.Range("D" & p + 9).Resize(, 6).Value = Sh.Range("D" & C.Row).Resize(, 6).Value
Else
ws.Range("K" & p - 31).Resize(, 6).Value = Sh.Range("D" & C.Row + 40).Resize(, 6).Value
End If
End If
Next
Application.ScreenUpdating =true
End Sub

 

[2saad]

اتاذنا الفاضل / الأستاذ إبراهيم  ..بارك الله فيك وأكثر الله من أمثالك

الكود شغال تمام وظبط البيانات ونوعتها ..بس ناقص حاجة واحدة ويكتمل الكود كما هو مطلوب

وهو عايز الأولاد لوحدهم في عمود ( E) وعايز البنات وحدهم في عمود (L )..يبقي كده بارك الله فيك ..أنا عارف إني بتعبك معاي كتير ..أسف علي الخطأ / أستاذنا

قوائم.xlsm

 

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

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

تم الغاء شرط العدد 40 سواء بالنسبة للذكور او الاناث 

و اصبح الشرط هو انتماء التلميذ للفصل و النوع فقط   ..هذا و الله ولى التوفيق

Sub AdClass()
Const K1 = "ذكر": Const K2 = "أنثى"
Dim Sh As Worksheet, ws As Worksheet
Dim LR As Long, p As Long, q As Long
Dim Fsl As String, C As Range
Application.ScreenUpdating = False
Set Sh = Sheets("بيانات"): Set ws = Sheets("فصول")
ws.Range("D10:I49") = "": ws.Range("K10:P49") = ""
LR = Sh.Range("E" & Rows.Count).End(3).Row
Fsl = ws.Range("O7").Value
For Each C In Sh.Range("J10:J" & LR)
If C.Value = Fsl And C.Offset(0, -3) = K1 Then
p = p + 1
ws.Range("D" & p + 9).Resize(, 6).Value = Sh.Range("D" & C.Row).Resize(, 6).Value
ElseIf C.Value = Fsl And C.Offset(0, -3) = K2 Then
q = q + 1
ws.Range("K" & q + 9).Resize(, 6).Value = Sh.Range("D" & C.Row).Resize(, 6).Value
End If
Next
Application.ScreenUpdating = True
End Sub

 

[2saad]

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

معلش يا أستاذ إبراهيم ..فيه ملحوظة كمان في الكود

مش عايزه يمسح اي بيانات بعد الصف 43 علشان هكتب بيانات تحت ( وكيل شئون الطلبة - مدير المدرسة ) وهكذا ..انا آسف بتعبك معاي

قوائم.xlsm

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

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

اخى الكريم الكود يقوم بمسح البيانات حتى الصف رقم 49  ..سيتم رفع الملف بعد التعديلات لصعوبة تطبيقها بنفسك

قوائم.xlsm

[2saad]

عشمي في سؤال

ايه الفرق بين زر ( عرض الفصول ) وزر ( الطباعة دفعة واحدة )

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

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

بالنسبة للزر الاول هو لعرض بيانات فصل محدد من القائمة المنسدلة دون طباعة 

اما الزر الثانى فهو مخصص لعرض  الفصول بداية من الفصل الاول حتى الاخير و طباعته مباشرة ..الكود التالى لطباعة ورقة محددة بعد عرضها عن طريق الزر الاول

Sub PrnData()  
ActiveWindow.SelectedSheets.PrintOut From:=1, To:=1, Copies:=1, Collate _
:=True, IgnorePrintAreas:=False
End Sub

 

[2saad]

شكرا جزيلا بس فيه ملحوظ عند طباعة الكل يطبع الصفحة الأولي فارغة . لماذا ؟

 

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

السلام عليكم ورحمة الله ..الارقام فى هذا السطر بالكود اجعلها هكذا

Fsl = WorksheetFunction.Index(ws.Range("S8:T" & xx + 7), i, 1)

يعنى 7 يتحول الى 8 و 6 يتحول الى 7

[2saad]

شكرا جزيلا يا أستاذ ابراهيم ..وجعله الله في ميزان حسناتك