مساعدة فى عمل قوائم

[abomalk]

قوائم.xlsm

[وجيه شرف الدين]

اتفضل لعله يفى بالغرض

فى شيت fasl2 عند الاختيار من القائمة المنسدلة الفصل يجلب لك اسماء الطلاب ولغيت لك زر استدعاء الطلاب

Copy of قوائم.xlsm

[سليم حاصبيا]

جرب هذا الماكرو

تم تعديل القوائم المنسدلة في الشيت fasl  و الشيت  fasl2  النطاق  "K1"  ليتناسب مع كل الاحنمالات

في الشيت main  الزر All In One1 يعمل الفلترة وينقلها الى  كل شيت بمفردها
   في الشيت fasl  و الشيت  fasl2   الزر استدعاء  يتفذ الماكرو الخاص بكل منهما   

(مع الترقيم اوتوماتيكي بدون معادلات لتصغير حجم الملف من جهة و من جهة احرى لعدم العبث بالمعادلات  اذا وجدت
                        عن طربق  الحطأ )

Option Explicit
Private M As Worksheet
Private F1 As Worksheet
Private F2 As Worksheet
Private LM%, LF1%, LF2%
Private M_rg As Range, F1_rg As Range
Private F2_rg As Range
Private Filter_range As Range
Private Cret1$, Cret2$
Private cont
Private y%
'++++++++++++++++++++++++++++++
Sub Get_all()
My_filter_forF1
My_filter_forF2

End Sub

Sub My_filter_forF1()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
 First_Macro
On Error Resume Next
 F1.Range("A6:J30").ClearContents
 Set Filter_range = F1.Range("k1")
 If M.AutoFilterMode Then M.Range("A3").AutoFilter
  M_rg.AutoFilter 5, Filter_range

  M_rg.AutoFilter 7, Cret1
        M.Range("B4:B" & LM).SpecialCells(12).Copy
        F1.Range("B6").PasteSpecial (12)
      
        M.Range("G4:G" & LM).SpecialCells(12).Copy
        F1.Range("C6").PasteSpecial (12)
      
        M.Range("H4:H" & LM).SpecialCells(12).Copy
        F1.Range("D6").PasteSpecial (12)
      
        M.Range("I4:I" & LM).SpecialCells(12).Copy
        F1.Range("E6").PasteSpecial (12)
      cont = Application.CountA(F1.Range("B6:B25"))
       If cont > 0 Then
        F1.Range("A6").Resize(cont) = _
        Evaluate("ROW(1:" & cont & ")")
       End If
       
   M_rg.AutoFilter 7, Cret2
 M.Range("B4:B" & LM).SpecialCells(12).Copy
   F1.Range("G6").PasteSpecial (12)
   
   M.Range("G4:G" & LM).SpecialCells(12).Copy
   F1.Range("H6").PasteSpecial (12)
   
   M.Range("H4:H" & LM).SpecialCells(12).Copy
   F1.Range("I6").PasteSpecial (12)
   
   M.Range("I4:I" & LM).SpecialCells(12).Copy
   F1.Range("J6").PasteSpecial (12)

 cont = Application.CountA(F1.Range("G6:G25"))
    If cont > 0 Then
     F1.Range("F6").Resize(cont) = _
     Evaluate("ROW(1:" & cont & ")")
    End If

If M.AutoFilterMode Then M.Range("A3").AutoFilter
On Error GoTo 0
 With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
'+++++++++++++++++++++++++++++++++++++
Sub My_filter_forF2()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
 First_Macro
On Error Resume Next
 F2.Range("A6:J30").ClearContents
 Set Filter_range = F2.Range("k1")
 If M.AutoFilterMode Then M.Range("A3").AutoFilter
  M_rg.AutoFilter 5, Filter_range

  M_rg.AutoFilter 7, Cret1
        M.Range("B4:B" & LM).SpecialCells(12).Copy
        F2.Range("B6").PasteSpecial (12)
      
        M.Range("G4:G" & LM).SpecialCells(12).Copy
        F2.Range("C6").PasteSpecial (12)
      
        M.Range("H4:H" & LM).SpecialCells(12).Copy
        F2.Range("D6").PasteSpecial (12)
      
        M.Range("I4:I" & LM).SpecialCells(12).Copy
        F2.Range("E6").PasteSpecial (12)
      cont = Application.CountA(F2.Range("B6:B25"))
       If cont > 0 Then
        F2.Range("A6").Resize(cont) = _
        Evaluate("ROW(1:" & cont & ")")
       End If
       
   M_rg.AutoFilter 7, Cret2
 M.Range("B4:B" & LM).SpecialCells(12).Copy
   F2.Range("G6").PasteSpecial (12)
   
   M.Range("G4:G" & LM).SpecialCells(12).Copy
   F2.Range("H6").PasteSpecial (12)
   
   M.Range("H4:H" & LM).SpecialCells(12).Copy
   F2.Range("I6").PasteSpecial (12)
   
   M.Range("I4:I" & LM).SpecialCells(12).Copy
   F2.Range("J6").PasteSpecial (12)

 cont = Application.CountA(F2.Range("G6:G25"))
    If cont > 0 Then
     F2.Range("F6").Resize(cont) = _
     Evaluate("ROW(1:" & cont & ")")
    End If

If M.AutoFilterMode Then M.Range("A3").AutoFilter
On Error GoTo 0
 With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
''++++++++++++++++++++++++++++++
Sub First_Macro()
Set M = Sheets("main")
Set F1 = Sheets("fasl")
Set F2 = Sheets("fasl2")
LM = M.Cells(Rows.Count, 2).End(3).Row
LF1 = F1.Cells(Rows.Count, 1).End(3).Row
If LF1 < 6 Then LF1 = 6
LF2 = F2.Cells(Rows.Count, 1).End(3).Row
If LF2 < 6 Then LF2 = 6
Set M_rg = M.Range("A3:I" & LM)
Set F1_rg = F1.Range("A6:J30")
Set F2_rg = F2.Range("A6:J30")
Cret1 = "ذكر": Cret2 = "أنثى"

End Sub

الملف مرفق

 

Abou_malak.xlsm

[abomalk]

معلمينا الافاضل بارك الله فيكم على الاهتمام والرد على موضوعى 
استاذناالفاضل وجيه شرف حضرتك هو لازم عمل الاعمدة المساعدة مينفعش دالتين index &match تبحث مباشرة فى الجدول 

استاذا الكبير الاستاذ سليم دائما رائع بهذة الاكواد الجميلة 
اتمنى من حضرتك البحث بمعادلتين index&match لاتقان هذة الدالتين ومعلش حضرتك عايزكود طباعة للصفوف التى بها بيانات فقط واخفاء الفارغةعندالطباعة 

[سليم حاصبيا]

تم ادراج صفحة للعمل بواسطة المعادلات " Section_1 "

تم معالجة الأمر بالنسبة للطباعة

الزر "Show hidden Rows" يظهر لك الصفوف المخفية (فارغة)

الماكرو يظهر لك معاينة قبل الطباعة  رز  " معاينة الطباعة "

لاستبدال الامر الى الطباعة المباشرة

غير السطر (الثالث من اخر الماكرو الأول)     و لا تنس كتابة النقطة قبله     من      PrintPreview         الى        PrintOut

Option Explicit
Sub Print_areas()
Dim Mx1%, Mx2%, Mx
Show_rows
If ActiveSheet.Name = "main" Then Exit Sub
With ActiveSheet
Mx1 = Application.Max(Range("A6:A30")) + 5
Mx2 = Application.Max(Range("F6:F30")) + 5
Mx = Application.Max(Mx1, Mx2) + 1
.Range("A" & Mx & ":A" & 30).EntireRow.Hidden = True
.PageSetup.PrintArea = .Range("A1:J31").Address
.PrintPreview
End With
End Sub
'++++++++++++++++++++++++++++
Sub Show_rows()
If ActiveSheet.Name = "main" Then Exit Sub
ActiveSheet.Range("A6:A30").EntireRow.Hidden = False
End Sub

الملف من جديد

 

Abou_malak_new.xlsm

[abomalk]

ربنا يبارك فيك استاذنا الفاضل ويبارك فى علمك ويجعله فى ميزان حسناتك 

ومعلش أنا أثقلت على حضرتك 

[سليم حاصبيا]

اعد تحمبل الملف من جديد لأنه ظهر هناك خطأ بسيط في معاينة الطباعة (تم اصلاحه)

 الخطأ يكمن في ان الطباعة تتم ابتداء من الصف السادس بينما المطلوب ان تتم ابتداء من الصف الأول

 وذلك باستبدال الرقم 6 بالرقم 1 قي هذا السطر   Range("A6:J31").Address

[abomalk]

الله عليك استاذنا الكبير(سليم) الف مليون تحيه وتقدير لحضرتك 
تم عمل كل المطلوب وبكفاءة عالية .... بفضل مجهودات حضرتك
الحمدلله رب العالمين