Option Explicit
Private Type TypeArguments
Action As Long
Formula As String
Cells As Excel.Range
Caller As Range
field As String
Criteria1 As Variant
operator As XlAutoFilterOperator
Criteria2 As Variant
VisibleDropDown As Boolean
SubField As Boolean
title As String
End Type
#If VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If
''///////////////////////////////////////////////////////
Private Works() As TypeArguments
Function afoAnd(): afoAnd= xlAnd: End Function
Function afoBottom10Items(): afoBottom10Items = xlBottom10Items: End Function
Function afoBottom10Percent(): afoBottom10Percent = xlBottom10Percent: End Function
Function afoFilterAutomaticFontColor(): afoFilterAutomaticFontColor = xlFilterAutomaticFontColor: End Function
Function afoFilterCellColor(): afoFilterCellColor = xlFilterCellColor: End Function
Function afoFilterDynamic(): afoFilterDynamic = xlFilterDynamic: End Function
Function afoFilterFontColor(): afoFilterFontColor = xlFilterFontColor: End Function
Function afoFilterIcon(): afoFilterIcon = xlFilterIcon: End Function
Function afoFilterNoFill(): afoFilterNoFill = xlFilterNoFill: End Function
Function afoFilterNoicon(): afoFilterNoicon = xlFilterNoIcon: End Function
Function afoFilterValues(): afoFilterValues = xlFilterValues: End Function
Function afoOr(): afoOr = xlOr: End Function
Function afoTop10Items(): afoTop10Items = xlTop10Items: End Function
Function afoTop10Percent(): afoTop10Percent = xlTop10Percent: End Function
Function AutoFilter( _
ByVal Cells As Range, _
Optional field As String = vbNullChar, _
Optional Criteria1 As Variant, _
Optional operator As XlAutoFilterOperator = 1, _
Optional Criteria2 As Variant, _
Optional VisibleDropDown As Boolean = True, _
Optional SubField As Boolean, _
Optional title As String = vbNullChar)
On Error Resume Next
If Cells.Worksheet.ProtectContents = True Then
AutoFilter = "[SheetProtected]"
Exit Function
End If
Dim r As Object, k%, i%, s$, F$
s = Cells.Address(0, 0)
Set r = Application.ThisCell
F = r.Formula
If title <> vbNullChar Then AutoFilter = title
k = UBound(Works): k = k + 1
ReDim Preserve Works(1 To k)
With Works(k)
Set .Caller = r
Set .Cells = Cells
.Formula = F
n:
.Action = 0
.field = field
.Criteria1 = Criteria1
.operator = operator
.Criteria2 = Criteria2
.SubField = SubField
.VisibleDropDown = VisibleDropDown
End With
Set r = Nothing
Call SetTimer(Application.hwnd, 1111, 0, AddressOf S_AutoFilter_callback)
On Error GoTo 0
End Function
#If VBA7 And Win64 Then
Private Sub S_AutoFilter_callback(ByVal hwnd^, ByVal uMsg&, ByVal nIDEvent&, ByVal dwTimer&)
#Else
Private Sub S_AutoFilter_callback(ByVal hwnd&, ByVal uMsg&, ByVal nIDEvent&, ByVal dwTimer&)
#End If
On Error Resume Next
Call KillTimer(hwnd, nIDEvent)
S_AutoFilter_working
End Sub
Private Sub S_AutoFilter_working()
On Error Resume Next
Dim ub As Integer, a As Object, b As TypeArguments, i&, k&, su As Boolean, Ac As Boolean, v As Variant, rg As Range, cell
ub = UBound(Works)
Dim s$, o, sh
For i = 1 To ub
b = Works(i)
Select Case b.Action
Case 0
If b.Caller.Formula = b.Formula Then
' If a Is Nothing Then
' Set a = Application
' su = a.ScreenUpdating: If su Then a.ScreenUpdating = False
' Ac = a.Calculation = xlCalculationAutomatic: If Ac Then a.Calculation = xlCalculationManual
' End If
Set rg = b.Cells: Set sh = rg.Parent
If Not sh.AutoFilter Is Nothing Then
sh.AutoFilter.ShowAllData
End If
If b.Criteria2 = Empty Then
If b.SubField = Empty Then
b.Cells.AutoFilter field:=b.field, Criteria1:=b.Criteria1, operator:=b.operator, VisibleDropDown:=b.VisibleDropDown
Else
b.Cells.AutoFilter field:=b.field, Criteria1:=b.Criteria1, operator:=b.operator, Criteria2:=b.Criteria2, VisibleDropDown:=b.VisibleDropDown, SubField:=b.SubField
End If
Else
If b.SubField = Empty Then
b.Cells.AutoFilter field:=b.field, Criteria1:=b.Criteria1, operator:=b.operator, Criteria2:=b.Criteria2, VisibleDropDown:=b.VisibleDropDown
Else
b.Cells.AutoFilter field:=b.field, Criteria1:=b.Criteria1, operator:=b.operator, Criteria2:=b.Criteria2, VisibleDropDown:=b.VisibleDropDown, SubField:=b.SubField
End If
End If
Works(i).Action = 1
End If
End Select
k = k + 1
n:
Next
Erase Works
' If Not a Is Nothing Then
' If su And a.ScreenUpdating <> su Then a.ScreenUpdating = su
' If Ac And xlCalculationAutomatic <> a.Calculation Then a.Calculation = Ac
' Set a = Nothing
' End If
On Error GoTo 0
End Sub
)
