جرب هذا الماكرو
Option Explicit
Sub filter_for_ME()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Dim S_sh As Worksheet: Set S_sh = Sheets("ادخال البيانات")
Dim T_sh As Worksheet: Set T_sh = Sheets("كشف حساب")
Dim My_Table As Range: Set My_Table = S_sh.Range("A2").CurrentRegion
If Application.CountA(T_sh.Range("b1:b3")) < 3 Then
T_sh.Range("a5").CurrentRegion.ClearContents
MsgBox "هناك بيانات ناقصة في أحد الخلايا : B1,B2,B3 " & Chr(10) & _
"لا استطيع الفلترة" & " " & "( بأمر من سليم )", 1572880
GoTo Exit_Sub
End If
With T_sh
.Range("a5").CurrentRegion.ClearContents
.Range("q2").Formula = "=AND('ادخال البيانات'!$G3=$B$1,'ادخال البيانات'!$B3>=$B$2,'ادخال البيانات'!$B3<=$B$3)"
My_Table.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=T_sh.Range("Q1:q2"), _
CopyToRange:=.Range("A5")
.Range("q2").ClearContents
.Columns("D:P").AutoFit
End With
Exit_Sub:
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
الملف مرفق
موردين Salim.xlsm