بعد اذن اخي شريغ هذا الكود (يمكن ان يكون اسرع قليلاُ)
Option Explicit
Sub Filter_For_Me()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
On Error GoTo Exit_sub
Dim i%
Dim t%
Dim arr(): arr = Array("م", "غ", "<50", "صفر")
Dim My_Rg As Range
Dim FinaL_row%: FinaL_row = Sheets("data").Cells(Rows.Count, 2).End(3).Row
Set My_Rg = Sheets("data").Range("b2:M" & FinaL_row)
For i = 2 To Sheets.Count
With Sheets(i)
.Range("a2:M1000").Clear
.Range("Xfd1") = .Name
.Range("xfd2").Resize(4, 1) = Application.Transpose(arr)
My_Rg.AdvancedFilter Action:=2, _
CriteriaRange:=.Range("xfd1:xfd5"), _
CopyToRange:=.Range("a2"), Unique:=False
.Range("a1").CurrentRegion.Columns.AutoFit
.Range("xfd1:xfd5").Clear
For t = 12 To 5 Step -1
If .Cells(2, t) <> .Name Then .Cells(2, t).EntireColumn.Delete
Next t
End With
Next i
Exit_sub:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
Erase arr
End Sub
الملف مرفق
استدعاءبشروط Salim1.xlsm