أخي الكريم علي المصري
إثراءً للموضوع وإضافة للحل الرائع المقدم من أخونا المتميز سليم إليك حل بالأكواد مع الشرح بالتفصيل ..لتستطيع التعديل بما يتناسب مع ملفك الأصلي
Sub FilterMarks()
'تعريف المتغيرات
Dim Counter As Integer, LR As Integer, I As Integer
'إلغاء تحديث الشاشة لتسريع الكود
Application.ScreenUpdating = False
'بدء التعامل مع ورقة العمل النشطة
With ActiveSheet
'مسح النطاق الذي ستوضع فيه النتائج
.Range("J10:M1000").ClearContents
'حلقة تكرارية من 1 إلى 3 حسب عدد الأعمدة التي سيتم التعامل معها
'فالأعمدة التي سيتم التعامل معها وفلترتها هي العمود ف1 و ف2 و ف3
For Counter = 1 To 3
'إلغاء الفلترة في ورقة العمل قبل البدء في عمليات الفلترة
.AutoFilterMode = False
'فلترة النطاق حسب الحقل رقم 2 في الحلقة الأولى ورقم 3 في الحلقة الثانية ورقم 4 في الحلقة الثالثة
'لنستطيع التعامل مع الثلاثة حقول ف1 و ف2 وف3 [Counter] وهنا استخدمنا المتغير المسمى
'وشرط الفلترة أكبر من الدرجة صفر وأقل من أو يساوي الدرجة 50
.Range("B2:E2").AutoFilter Field:=Counter + 1, Criteria1:=">0", Operator:=xlAnd, Criteria2:="<=50"
'نسخ النطاق الذي يحتوي الأسماء ويكون النسخ للخلايا الظاهرة فقط والتي تطابق الشروط
.Range("B3:B" & Cells(Rows.Count, "B").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy
'لصق الأسماء في العمود المناسب حيث يكون اللصق في أول حلقة في العمود رقم 11
'وفي الحلقة الثانية في العمود رقم 12 وفي الحلقة الثالثة في العمود رقم 13
'اللصق يكون للقيم فقط بحيث نحافظ على التنسيقات الموجودة في نطاق النتائج
.Cells(10, Counter + 10).PasteSpecial xlPasteValues
'تحديد أول خلية في ورقة العمل
.Range("A1").Select
'الانتقال للحلقة التالية
Next Counter
'إلغاء الفلترة في ورقة العمل
.AutoFilterMode = False
'تحديد آخر صف في نطاق النتائج من خلال معرفة عدد صفوف النطاق الحالي مضافاً إليها 7
'يمثل الرقم 7 عدد الصفوف السابقة للنطاق الحالي أي نطاق النتائج
LR = .Range("K9").CurrentRegion.Rows.Count + 7
'حلقة تكرارية من الصف رقم 10 إلى آخر صف في النطاق الحالي
For I = 10 To LR
'الخلية في العمود العاشر تساوي قيمة العداد مطروح منه 9 ليعطي تسلسل للنتائج
.Cells(I, "J") = I - 9
'الانتقال للحلقة التالية
Next I
'انتهاء التعامل مع ورقة العمل الحالية
End With
'إلغاء خاصية القص واللصق بعد عمليات النسخ
Application.CutCopyMode = False
'إعادة تفعيل تحديث الشاشة
Application.ScreenUpdating = True
End Sub
تقبل تحياتي
Filter & AutoFilter Tutorial YasserKhalil.rar