استدعاء أسماء التلاميذ المكملون بالمواد الدراسية

[عامر ياسر]

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

الشرح داخل ملف الاكسيل

aamir.xlsm

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

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

Option Explicit
Sub Salim_Index()
Application.ScreenUpdating = False
Dim S_sh As Worksheet: Set S_sh = Sheets("الدرجات")
Dim Index_sh As Worksheet: Set Index_sh = Sheets("قائمة")
If ActiveSheet.Name <> Index_sh.Name Then GoTo Leave_Me_Out
Dim my_st1$, my_st2$, my_st3$
Dim lr%: lr = S_sh.Cells(Rows.Count, 1).End(3).Row
Dim Flt_Rg As Range: Set Flt_Rg = S_sh.Range("a4:R" & lr)

Index_sh.Range("b5:c150").ClearContents

 my_st1 = "=" & Index_sh.[j1]
 my_st2 = "=" & Index_sh.[j2]
 my_st3 = "=" & Index_sh.[j3]
    Flt_Rg.AutoFilter Field:=13, Criteria1:=my_st1
    Flt_Rg.AutoFilter Field:=4, Criteria1:=my_st2
    Flt_Rg.AutoFilter Field:=15, Criteria1:=my_st3
    
         Flt_Rg.Columns(2).SpecialCells(xlCellTypeVisible).Copy
         Index_sh.Range("b4").PasteSpecial Paste:=xlPasteValues
    
    Flt_Rg.Columns(3).SpecialCells(xlCellTypeVisible).Copy
     Index_sh.Range("c4").PasteSpecial Paste:=xlPasteValues
     Application.CutCopyMode = False
    Flt_Rg.AutoFilter


Leave_Me_Out:
   Application.ScreenUpdating = True
End Sub

الملف مرفق

 

filter by 3 Criterias.xlsm

[عامر ياسر]

جزاك الله خيرا استاذنا سليم حاصبيا .... توجد مشكلة وهي عند اختيار    الاول - أ     كمثال واختار العربية* .......اذا كانت في مواد الرسوب في البداية كلمة العربية* يقوم بجلب الاسماء اما اذا كانت على هذا النحو     ....      الاسلامية* العربية* لا يقوم بجلب اسماء المكملون بالعربية مما يؤثر على دقة جلب البيانات اي ان هناك اسماء على سبيل المثال مكملة بالعربي ولا يجلبها مثل اسم احمد9 وهكذا 

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

تم التعديل

Option Explicit
Sub Salim_Index()
Application.ScreenUpdating = False
Dim S_sh As Worksheet: Set S_sh = Sheets("الدرجات")
Dim Index_sh As Worksheet: Set Index_sh = Sheets("قائمة")
If ActiveSheet.Name <> Index_sh.Name Then GoTo Leave_Me_Out
Dim my_st1$, my_st2$, my_st3$
Dim lr%: lr = S_sh.Cells(Rows.Count, 1).End(3).Row
Dim Flt_Rg As Range: Set Flt_Rg = S_sh.Range("a4:R" & lr)

Index_sh.Range("b5:c150").ClearContents

 my_st1 = "=" & Index_sh.[j1]
 my_st2 = "=" & Index_sh.[j2]
 my_st3 = Replace(Index_sh.[j3], "*", "")
 my_st3 = "*" & my_st3 & "*"
    Flt_Rg.AutoFilter Field:=13, Criteria1:=my_st1
    Flt_Rg.AutoFilter Field:=4, Criteria1:=my_st2
    Flt_Rg.AutoFilter Field:=15, Criteria1:= _
        "=" & my_st3, Operator:=xlAnd
    '===========================
   
      Flt_Rg.Columns(2).SpecialCells(xlCellTypeVisible).Copy
      Index_sh.Range("b4").PasteSpecial Paste:=xlPasteValues
    
    Flt_Rg.Columns(3).SpecialCells(xlCellTypeVisible).Copy
     Index_sh.Range("c4").PasteSpecial Paste:=xlPasteValues
     Application.CutCopyMode = False
   Flt_Rg.AutoFilter
Leave_Me_Out:
   Application.ScreenUpdating = True
End Sub

الملف

 

filter by 3 Criterias_Modifier.xlsm

[عامر ياسر]

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

تم تعديل يوليو 16, 2018 بواسطه عامر ياسر

[ابوانس2013]

تسلم اياديكم