Tận dụng bộ lọc AutoFilter và AdvancedFilter với hàm UDF nhanh chóng
HÀM UDF AutoFilter và AdvFilter bổ trợ tận dụng hai bộ lọc AutoFilter và AdvancedFilter
Hôm nay tôi chia sẻ với các bạn hàm có thể gọi hai bộ lọc mà Application Excel hỗ trợ trong VBA hoặc phải cài đặt bằng tay trong Ribbon khá rối, thì nay đã có hàm bổ trợ này giúp các bạn thao tác gọn gàng và nhanh hơn để lọc dữ liệu mà các bạn cần hiệu quả hơn.
HƯỚNG DẪN:
Phương pháp viết hàm mới nên cách sử dụng hàm cũng đặc biệt khác với các hàm thông thường.
1. AutoFilter: là hàm bổ trợ cho phương thức AutoFilter của Range trong Application Excel
=AutoFilter(CurrentCells,FilterCells, Parameters())
1
CurrentCells
Vùng cần trả dữ liệu
2
FilterCells
Vùng đặt bộ lọc
3
Parameters()
Các đối số cài đặt cho bộ lọc
Hàm bổ trợ cho Hàm AutoFilter
Với các ký tự aft… là các hàm bổ trợ để cài đặt đối số để thực hiện lọc
aftField(1)
Giá trị
Cài đặt Field
aftCriteria1(">=1")
Giá trị
Đặt điều kiện lọc thứ nhất
aftCriteria2("<=10")
Có/Không
Đặt điều kiện lọc thứ hai
aftDisibleDropDown()
Không hiển thị nút lọc trên trang tính
aftSubField(1)
Giá trị
Cài đặt SubField
Ví dụ gõ hàm: =AutoFilter(A1:C1000,A1:A1000,aftCriteria1(">=1") )
Hàm bổ trợ Sắp xếp cho Hàm AutoFilter
=FilterSort(Parameters())
Với các ký tự aftSort… là các hàm bổ trợ để cài đặt đối số để thực hiện Sort cho Hàm AutoFilter
Các hàm này là đối số nằm trong hàm FilterSort hoặc AutoFilter
aftSortNotHeader()
Không
Đặt vùng sort không có tiêu đề
aftSortDescending()
Có
Đặt sắp xếp chiều ngược lại
aftSortMatchCase()
Có
Đặt điều kiện sắp xếp phân biệt Hoa Thường
aftSortMethod(Method)
Không hiển thị nút lọc trên trang tính
aftSortDataOption(DataOption)
aftSortOn(SortOn)
aftSortOrientation(Orientation)
Ví dụ gõ hàm: =AutoFilter(A1:C1000,A1:A1000,aftCriteria1(">=1") ,FilterSort(aftSortDescending(),aftSortMatchCase())
2. AdvFilter: là hàm bổ trợ cho phương thức AdvancedFilter trong Application Excel
****************(Sớm cập nhật)****************
***Lưu ý:
1. Phiên bản đầu tiên nên có các lỗi khi sử dụng, nên cần cập nhật và sửa lỗi, các bạn nên tham khảo và theo dõi chủ đề để cập nhật.
2. Chưa viết mã cho AdvFilter
3. Sẽ sớm cập nhật sắp xếp có cấp độ
Sao chép mã bên dưới vào một Module mới, và sử dụng hàm:
Option Explicit
Option Compare Text
Public Const ProjectName = "UDFFilterXL"
Public Const ProjectFileName = "AutoFilterXL"
Public Const projectVersion = "1.0"
' _,
' ___ _ _ _ ___(_)
'/ __| / | | | _ | |
'__ / | \ | _ |
'|___/_/ _|_|_|___/_|
'
Public Enum AutoFilterSettings
afsMainFXAutoFilter = 1
afsMainFXAdvancedFilter
afsFilterSort
afsField
afsCriteria1
afsOperator
afsCriteria2
afsDisibleDropDown
afsSubField
afsCells
' Sort -------------------------
afsSortDescending
afsSortOn
afsSortDataOption
afsSortNotHeader
afsSortMatchCase
afsSortOrientation
afsSortMethod
End Enum
Private Type TypeArguments
timer As Single
Action As Long
direction As Long
Target As Variant
address As String
caller As Range
formula As String
Field As Variant
Criteria1 As Variant
Operator As XlAutoFilterOperator
Criteria2 As Variant
DisibleDropDown As Boolean
SubField As Variant
Title As String
actionFT As XlFilterAction
CriteriaRange As Range
CopyToRange As Range
Unique As Boolean
resultArray As Variant
Cells As Range
CurrentCells As Range
XLNew As Boolean
OnUndo As Boolean
FilterSort As Boolean
SortDescending As Boolean ' xlAscending
SortOn As XlSortOn ' xlSortOnValues
SortDataOption As XlSortDataOption ' = xlSortNormal
SortHeader As Boolean
SortMatchCase As Boolean
SortOrientation As Long
SortMethod As XlSortMethod
End Type
#If VBA7 Then
Public Declare PtrSafe Function SetTimer Lib "USER32" (ByVal Hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
Public Declare PtrSafe Function KillTimer Lib "USER32" (ByVal Hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
Public Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If
Private Works() As TypeArguments
Function afoBottom10Items(): AddArgumentsFilter afsOperator, xlBottom10Items: End Function
Function afoBottom10Percent(): AddArgumentsFilter afsOperator, xlBottom10Percent: End Function
Function afoFilterAutomaticFontColor(): AddArgumentsFilter afsOperator, xlFilterAutomaticFontColor: End Function
Function afoFilterCellColor(): AddArgumentsFilter afsOperator, xlFilterCellColor: End Function
Function afoFilterDynamic(): AddArgumentsFilter afsOperator, xlFilterDynamic: End Function
Function afoFilterFontColor(): AddArgumentsFilter afsOperator, xlFilterFontColor: End Function
Function afoFilterIcon(): AddArgumentsFilter afsOperator, xlFilterIcon: End Function
Function afoFilterNoFill(): AddArgumentsFilter afsOperator, xlFilterNoFill: End Function
Function afoFilterNoicon(): AddArgumentsFilter afsOperator, xlFilterNoIcon: End Function
Function afoFilterValues(): AddArgumentsFilter afsOperator, xlFilterValues: End Function
Function afoAnd(): AddArgumentsFilter afsOperator, xlAnd: End Function
Function afoOr(): AddArgumentsFilter afsOperator, xlOr: End Function
Function afoTop10Items(): AddArgumentsFilter afsOperator, xlTop10Items: End Function
Function afoTop10Percent(): AddArgumentsFilter afsOperator, xlTop10Percent: End Function
'=AutoFilter(B4:AF24,C4:C24,aftField(1),aftCriteria1(">="&C1),aftCriteria2("<="&C2),afoAnd())
Function AdvFilter(ByVal CurrentCells As Range, ByVal FilterCells As Range, ParamArray arguments()) As Variant
AdvFilter = AddArgumentsFilter(afsMainFXAdvancedFilter, CurrentCells, FilterCells)
End Function
Function AutoFilter(ByVal CurrentCells As Range, ByVal FilterCells As Range, ParamArray arguments()) As Variant
AutoFilter = AddArgumentsFilter(afsMainFXAutoFilter, CurrentCells, FilterCells)
End Function
Function FilterSort(ParamArray arguments()) As Variant
Call AddArgumentsFilter(afsFilterSort, arguments)
End Function
Function aftSortDescending()
AddArgumentsFilter afsSortDescending, True
End Function
Function aftSortOn(Optional SortOn As XlSortOn = xlSortOnValues)
AddArgumentsFilter afsSortDataOption, SortOn
End Function
Function aftSortDataOption(Optional DataOption As XlSortDataOption = xlSortNormal)
AddArgumentsFilter afsSortDataOption, DataOption
End Function
Function aftSortNotHeader()
AddArgumentsFilter afsSortNotHeader, False
End Function
Function aftSortMatchCase()
AddArgumentsFilter afsSortMatchCase, True
End Function
Function aftSortOrientation(Optional Orientation As Long = xlTopToBottom)
AddArgumentsFilter afsSortOrientation, Orientation
End Function
Function aftSortMethod(Optional Method As XlSortMethod = xlPinYin)
AddArgumentsFilter afsSortMethod, Method
End Function
Function aftField(Field As Variant) As Variant
AddArgumentsFilter afsField, Field
End Function
Function aftCriteria1(Criteria As Variant) As Variant
AddArgumentsFilter afsCriteria1, Criteria
End Function
Function aftOperator(Optional Operator As XlAutoFilterOperator = xlAnd) As XlAutoFilterOperator
AddArgumentsFilter afsOperator, Operator
End Function
Function aftCriteria2(Criteria As Variant)
AddArgumentsFilter afsCriteria2, Criteria
End Function
Function aftDisibleDropDown() As String
AddArgumentsFilter afsDisibleDropDown, False
End Function
Function aftSubField(SubField As Variant) As Variant
AddArgumentsFilter afsSubField, SubField
End Function
Private Function AddArgumentsFilter(direction%, ParamArray arguments())
On Error Resume Next
Dim k%, i%, r As Object, s$, f$, w As TypeArguments, n As Boolean
Set r = Application.ThisCell: If r Is Nothing Then Exit Function
If r.Worksheet.ProtectContents = True Then AddArgumentsFilter = "[SheetProtected]": Exit Function
XLAppVersion n
If n Then f = r.Formula2 Else f = r.formula
If Not f Like "*AutoFilter(*" Then Exit Function
s = r.address(0, 0, , 1)
k = UBound(Works):
If k > 0 Then
For i = 1 To k
With Works(i)
If s = .address And f = .formula Then
Select Case .Action
Case 1: k = i: GoTo s
Case 2: Exit Function
Case 3: Exit Function
If direction = afsMainFXAutoFilter Then
If n Then .direction = -1
.Action = 4
AddArgumentsFilter = .resultArray: Call SetTimer(Application.Hwnd, 1113, 0, AddressOf S_AutoFilter_callback)
End If
Exit Function
End Select
Exit For
End If
End With
Next
End If
k = k + 1
ReDim Preserve Works(1 To k)
With Works(k): .XLNew = n: .Action = 1: .OnUndo = False: .direction = 0: Set .caller = r: .address = s: .formula = f: .Operator = 1: .Field = 1
.SortDescending = False
.SortHeader = True
.SortMatchCase = False
.SortOn = xlSortOnValues
.SortDataOption = True
.FilterSort = False
.SortMethod = xlPinYin
.SortOrientation = xlTopToBottom
End With
s:
With Works(k)
Select Case direction
Case afsFilterSort: .FilterSort = True
Case afsMainFXAdvancedFilter: .direction = direction
Case afsMainFXAutoFilter: .direction = direction
.OnUndo = Application.CommandBars("Standard").Controls("&Undo").List(1) = "Filter"
.timer = timer: Set .CurrentCells = arguments(0): Set .Cells = arguments(1): Call FilterSetTimer
Case afsField: .Field = arguments(0)
Case afsCriteria1: .Criteria1 = arguments(0)
Case afsOperator: .Operator = arguments(0)
Case afsCriteria2: .Criteria2 = arguments(0)
Case afsDisibleDropDown: .DisibleDropDown = True
Case afsSubField: .SubField = arguments(0)
Case afsSortDescending: .SortDescending = True
Case afsSortNotHeader: .SortHeader = False
Case afsSortMatchCase: .SortMatchCase = True
Case afsSortDataOption: .SortDataOption = arguments(0)
Case afsSortOn: .SortOn = arguments(0)
Case afsSortDescending: .SortDescending = True
Case afsSortOrientation: .SortOrientation = arguments(0)
End Select
End With
End Function
''///////////////////////////////////////////////////////
Private Sub FilterSetTimer()
Call SetTimer(Application.Hwnd, 1111, 0, AddressOf S_AutoFilter_callback)
End Sub
#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)
Select Case nIDEvent
Case 1111: S_AutoFilter_working
Case 1113:
Dim k%, i%, j%
k = UBound(Works):
For i = 1 To k
If Works(i).Action = 4 Then j = j + 1
Next
If j = k Then Erase Works
End Select
End Sub
'learn.microsoft.com/en-us/office/vba/api/excel.range.sort?source=recommendations
Private Sub S_AutoFilter_working()
'If ThisWorkbook.BookJustSaved Then Erase Works: Exit Sub
Dim ub As Integer, a As Object, b As TypeArguments, i&, k&, lr&, r1&, su As Boolean, ac As Boolean, ee 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 1
If b.caller.formula = b.formula Then
If a Is Nothing Then
Set a = Application
su = a.ScreenUpdating: If su Then a.ScreenUpdating = False
ee = a.EnableEvents: If ee Then a.EnableEvents = 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
If IsEmpty(b.Criteria2) Then
If IsEmpty(b.SubField) Then
b.Cells.AutoFilter Field:=b.Field, Criteria1:=b.Criteria1, Operator:=b.Operator, VisibleDropDown:=Not b.DisibleDropDown
Else
b.Cells.AutoFilter Field:=b.Field, Criteria1:=b.Criteria1, Operator:=b.Operator, Criteria2:=b.Criteria2, VisibleDropDown:=Not b.DisibleDropDown, SubField:=b.SubField
End If
Else
If IsEmpty(b.SubField) Then
b.Cells.AutoFilter Field:=b.Field, Criteria1:=b.Criteria1, Operator:=b.Operator, Criteria2:=b.Criteria2, VisibleDropDown:=Not b.DisibleDropDown
Else
b.Cells.AutoFilter Field:=b.Field, Criteria1:=b.Criteria1, Operator:=b.Operator, Criteria2:=b.Criteria2, VisibleDropDown:=Not b.DisibleDropDown, SubField:=b.SubField
End If
End If
If b.FilterSort Then
With sh
.AutoFilter.Sort.SortFields.Clear
.AutoFilter.Sort.SortFields.Add2 _
Key:=b.CurrentCells, SortOn:=b.SortOn, Order:=1 - b.SortDescending, _
DataOption:=b.SortDataOption
With .AutoFilter.Sort: .Header = b.SortHeader: .MatchCase = False: .Orientation = b.SortOrientation: .SortMethod = b.SortMethod: .Apply: End With
End With
End If
lr = b.CurrentCells.rows.count
Set cell = b.CurrentCells(1, 1).MergeArea
r1 = cell.rows.count
If Not b.FilterSort Or Not b.SortHeader Then
Set cell = b.CurrentCells
Else
Set cell = b.CurrentCells.Offset(r1, 0).Resize(lr - r1)
End If
Works(i).resultArray = cell.Value2
If b.XLNew Then
b.caller.Formula2 = b.formula
Else
cell.Copy b.caller: b.caller.formula = b.formula
End If
Works(i).Action = 3
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 ee And a.EnableEvents <> ee Then a.EnableEvents = ee
'If ac And xlCalculationAutomatic <> a.Calculation Then a.Calculation = ac
Set a = Nothing
End If
On Error GoTo 0
End Sub
Private Function XLAppVersion(Optional newVersion As Boolean, Optional implicitIntersectionOperator$, Optional SpillOperator$) As Long
Static n&, v&, i1$, i2$
If n <> 0 Then XLAppVersion = v: newVersion = n = 1: implicitIntersectionOperator = i1: SpillOperator = i2: Exit Function
Dim registryObject As Object
Dim rootDirectory$
Dim keyPath$
Dim arrEntryNames As Variant
Dim arrValueTypes As Variant
Dim x&
Select Case val(Application.Version)
Case Is = 16
'Check for existence of Licensing key
i1 = "@"
keyPath = "SoftwareMicrosoftOffice" & CStr(Application.Version) & "CommonLicensingLicensingNext"
rootDirectory = "."
Set registryObject = GetObject("winmgmts:{impersonationLevel=impersonate}!\" & rootDirectory & "rootdefault:StdRegProv")
registryObject.EnumValues &H80000001, keyPath, arrEntryNames, arrValueTypes
On Error GoTo ErrorExit
For x = 0 To UBound(arrEntryNames)
If InStr(arrEntryNames(x), "365") > 0 Then n = 1: v = 365: Exit For
If InStr(arrEntryNames(x), "2019") > 0 Then
If Application.Build >= 14332 Then
'ProductCode: {90160000-000F-0000-1000-0000000FF1CE}
'CalculationVersion: 191029
n = 1: i2 = "#": v = 2021
Else
n = -1: v = 2019
End If
Exit For
End If
If InStr(arrEntryNames(x), "2016") > 0 Then v = 2016: n = -1: Exit For
Next x
Case Is = 15: n = -1: v = 2013
Case Is = 14: n = -1: v = 2010 'ProductCode: {91140000-0011-0000-1000-0000000FF1CE} 'CalculationVersion: 145621
Case Is = 12: n = -1: v = 2007
Case Else: n = -1: v = 0
End Select
newVersion = n = 1: XLAppVersion = v: implicitIntersectionOperator = i1: SpillOperator = i2
Exit Function
ErrorExit:
'Version 16, but no licensing key. Must be Office 2016
v = 2016: n = -1: XLAppVersion = v: newVersion = n = 1
End Functionwww.giaiphapexcel.com/diendan/threads/t%E1%BA%ADn-d%E1%BB%A5ng-b%E1%BB%99-l%E1%BB%8Dc-autofilter-v%C3%A0-advancedfilter-v%E1%BB%9Bi-h%C3%A0m-udf-nhanh-ch%C3%B3ng.164047/
Khóa học SprinGO phù hợp
Khóa học Power PI – Ứng dung trong Nhân sự
TỔNG QUAN KHÓA HỌC: POWER BI CHO NGÀNH NHÂN SỰ Khóa học Power BI cho Nhân sự được thiết kế dành riêng cho các...
Xem khóa học
Bình luận