اذهب الي المحتوي
أوفيسنا

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


abomalk
إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

الردود الموصى بها

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

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

Copy of قوائم.xlsm

  • Like 1
رابط هذا التعليق
شارك

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

تم تعديل القوائم المنسدلة في الشيت 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

  • Like 1
رابط هذا التعليق
شارك

معلمينا الافاضل بارك الله فيكم على الاهتمام والرد على موضوعى 
استاذناالفاضل وجيه شرف حضرتك هو لازم عمل الاعمدة المساعدة مينفعش دالتين 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

  • Thanks 1
رابط هذا التعليق
شارك

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

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

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

  • Like 1
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information