HeSanbi
Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨
- Tham gia
- 24/2/13
- Bài viết
- 2,591
- Được thích
- 3,991
- Giới tính
- Nam
HÀM UDF FilterA và FilterV 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.
Tại sao nên sử dụng AutoFilter và AdvancedFilter để lọc?
Đơn giản là vì chúng được sinh ra để lọc dữ liệu, là phương thức gốc, chạy xử lý đa luồng trong nền, nên rất nhanh. Nhanh thì Ngốn Tài Nguyên Máy tính.
AutoFilter và AdvancedFilter lọc dữ liệu như thế nào?
Cách đặt điều kiện cho hai phương thức là như nhau, rất đơn giản sử dụng các toán tử so sánh như sau:
Có 3 hàm hỗ trợ cho lọc dữ liệu dưới đây, gồm: FilterA, FilterV và AutoSort
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. FilterA: là hàm bổ trợ cho phương thức AutoFilter của Range trong Application Excel, chính là nút lọc trong mục Data -> Filter. Hoặc trong Menu Excel mới.
Hàm bổ trợ cho Hàm FilterA
Với việc gõ các ký tự fat… là tiền tố các hàm bổ trợ để cài đặt đối số để thực hiện lọc cho hàm FilterA
2. FilterV: là hàm bổ trợ cho phương thức AdvancedFilter trong Application Excel, chính là nút lọc trong mục Data -> Advanced Filter.
Ví dụ gõ hàm: =FilterA(A1:C1000,ftFid(1, ">=1") ,AutoSort(SortDescending(),SortMatchCase()))
***Lưu ý:
Sao chép mã bên dưới vào một Module mới, và sử dụng hàm:
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.
Tại sao nên sử dụng AutoFilter và AdvancedFilter để lọc?
Đơn giản là vì chúng được sinh ra để lọc dữ liệu, là phương thức gốc, chạy xử lý đa luồng trong nền, nên rất nhanh. Nhanh thì Ngốn Tài Nguyên Máy tính.
AutoFilter và AdvancedFilter lọc dữ liệu như thế nào?
- AutoFilter Lọc tối đa chỉ hai điều kiện cho mỗi cột, đặt điều kiện trực tiếp trong phương thức. AutoFilter lọc đa dạng hơn AdvancedFilter, như lọc bởi Màu, ...
- AdvancedFilter lọc nhiều điều kiện cho mỗi cột, nhận điều kiện từ vùng ô trong Trang tính. Có thể lọc bỏ qua dữ liệu trùng.
Cách đặt điều kiện cho hai phương thức là như nhau, rất đơn giản sử dụng các toán tử so sánh như sau:
- = So sánh bằng nhau
- <> So sánh khác nhau
- > So sánh lớn hơn
- < So sánh nhỏ hơn
- >= Lớn hơn hoặc bằng
- <= Nhỏ hơn hoặc bằng
- ? sẽ chụp lại bất kì ký tự nào, ví dụ điều kiện đặt là "=3?" thì kiểm tra xem cột dữ liệu có đúng là 3 kết hợp với một ký tự bất kì.
- * sẽ chụp chuỗi bất kì, ví dụ điều kiện đặt là "=3*" thì kiểm tra xem cột dữ liệu có đúng là 3 kết hợp với chuỗi bất kì.
Có 3 hàm hỗ trợ cho lọc dữ liệu dưới đây, gồm: FilterA, FilterV và AutoSort
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. FilterA: là hàm bổ trợ cho phương thức AutoFilter của Range trong Application Excel, chính là nút lọc trong mục Data -> Filter. Hoặc trong Menu Excel mới.
=FilterA(DataCells, Parameters())
1 | DataCells | Vùng dữ liệu cần lọc |
2 | Parameters() | Các đối số cài đặt cho bộ lọc |
Hàm bổ trợ cho Hàm FilterA
Với việc gõ các ký tự fat… là tiền tố các hàm bổ trợ để cài đặt đối số để thực hiện lọc cho hàm FilterA
Chính là Viết tắt từ FilterAuto
| ftFid(2,">=2", "<=5") | Cột sẽ lọc ở vị trí thứ 2, điều kiện lọc ">=2" và "<=5" | |
| iAnd() (mặc định) | Toán tử để lọc là And (và) | |
| iOR() | Toán tử để lọc là OR (hoặc) | |
| fatDisibleDropDown() | Không hiển thị nút lọc trên trang tính | |
| fatSubField(1) | Giá trị | Cài đặt SubField |
Ví dụ gõ hàm: =FilterA(A1:C1000,ftFid(1, ">=1", "<=3") )
Chỉ gõ ftFid(1, ">=1", "<=3") thì mã hiểu là toán tử And sẽ được sử dụng
Để sử dụng Toán tử OR có 2 cách gõ:
- Cách 1: lòng vào trong Field: ftFid(1, ">=3", "<=1", iOR())
- Cách 2: Gõ tổng quát: iOR(ftFid(1,">=3", "<=1"))
Ví dụ lọc cột 1 cần giá trị là 20 hoặc 30 và cột 2 phải khác 0, thì hàm viết như sau:
=FilterA(A1:C1000,iAnd(ftFid(1, "=20"), ftFid(2, "<>0")),iAnd(ftFid(1, "=30"), ftFid(2, "<>0")))
*** Chú ý lọc nhiều điều kiện phải gõ tổng quát, không lòng vào trong Field.
****Còn một trường hợp nữa nhưng tôi chưa viết mã (Sẽ cập nhật sau):
=FilterA(A1:C1000,iAnd(ftFid(1, "=20"), ftFid(2, "<>0"),iOR(ftFid(1,">=3", "<=1")))))
Các bạn sẽ thấy hàm đại diện toán tử OR nằm trong iAnd
2. FilterV: là hàm bổ trợ cho phương thức AdvancedFilter trong Application Excel, chính là nút lọc trong mục Data -> Advanced Filter.
=FilterV(DataCells, Parameters())
1 | DataCells | Vùng dữ liệu cần lọc |
2 | Parameters() | Các đối số cài đặt cho bộ lọc |
Các Hàm bổ trợ Parameters cho FilterV :
1 | favCriterias(Cell) | Vùng điều lọc |
2 | favCopyTo(Cell) | Vùng trả kết quả (Nếu hàng đầu tiên chứa tiêu đề cột nào, thì kết quả chỉ gồm tiêu đề cột đó) |
3 | favUnique | Lọc loại bỏ trùng |
AdvancedFilter thì khi nhập Vùng dữ liệu DataCells phải bao gồm phần Tiêu đề, Đầu đề và vùng điều kiện cũng vậy đầu đề phải tương ứng, vùng điều kiện giống như vùng dữ liệu rút gọn chỉ còn dữ liệu không trùng.
Ví dụ 1: Lọc vùng A1:C1000, với vùng điều kiện F2:H3, sao chép kết quả đến ô Z1
(A1 đến C1 phải là Đầu Đề, và F2 đến H2 phải là đầu đề)
=FilterV(A1:C1000,favCriterias(F2:H3),favCopyTo(Z1))
Ví dụ loại bỏ trùng:
=FilterV(A1:C1000,favCriterias(F2:H3),favCopyTo(Z1),favUnique())
Với các ký tự đầu fav… là tiền tố các hàm bổ trợ để cài đặt đối số để thực hiện lọc cho hàm FilterV
Chính là Viết tắt từ FilterAdvanced
Ví dụ 2: Lọc vùng A1:J1000, vùng điều kiện K1:M2, chỉ trả kết quả các cột A,C,D,F,J
Thì gõ favCopyTo(Sheet2!A1:E1) trong đó vùng phải được đặt tiêu đề tương ứng như sau:
- A1 tiêu đề tương ứng tiêu đề cột A
- B1 tiêu đề tương ứng tiêu đề cột C
- C1 tiêu đề tương ứng tiêu đề cột D
- D1 tiêu đề tương ứng tiêu đề cột F
- E1 tiêu đề tương ứng tiêu đề cột J
Thì biểu thức =FilterV(A1:J1000,favCriterias(K1:M2),favCopyTo(Sheet2!A1:E1))
3. AutoSort: Hàm bổ trợ Sắp xếp cho dữ liệu đã lọc =AutoSort(Parameters())
Với các ký tự Sort… là các hàm bổ trợ để cài đặt đối số để thực hiện Sắp xếp
Các hàm này là đối số nằm trong hàm AutoSort hoặc FilterA hoặc FilterV
| SortNotHeader() | Không | Đặt vùng sort không có tiêu đề |
| SortDescending() | Có | Đặt sắp xếp chiều ngược lại |
| SortMatchCase() | Có | Đặt điều kiện sắp xếp phân biệt Hoa Thường |
| SortMethod(Method) | Không hiển thị nút lọc trên trang tính | |
| SortDataOption(DataOption) | ||
| SortOn(SortOn) | ||
| SortOrientation(Orientation) |
Ví dụ gõ hàm: =FilterA(A1:C1000,ftFid(1, ">=1") ,AutoSort(SortDescending(),SortMatchCase()))
***AutoSort cũng là một hàm chức năng nên có thể viết riêng cho dữ liệu không Filter
***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. Sẽ sớm cập nhật sắp xếp có cấp độ
3. Tôi chỉ viết hàm bổ trợ AutoFilter và AdvancedFilter cho linh hoạt hơn, chứ không khuyên các bạn nên sử dụng các hàm trên.
Sao chép mã bên dưới vào một Module mới, và sử dụng hàm:
JavaScript:
Option Explicit
Option Compare Text
Private Const ProjectName = "UDFFilterXL"
Private Const ProjectFileName = "AutoFilterXL"
Private Const projectVersion = "1.3"
' _,
' ___ _ _ _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'
Public Enum AutoFilterSettings
afsMainFXAutoFilter = 1
afsMainFXAdvancedFilter
afsFilterSort
afsCriteriaRange
afsCopyToRange
afsCriterias
afsOperator
afsDisibleDropDown
afsSubField
afsCells
afsAddField
afsTitle
afsUnique
' Sort -------------------------
afsSortDescending
afsSortOn
afsSortDataOption
afsSortNotHeader
afsSortMatchCase
afsSortOrientation
afsSortMethod
afsSortCustom
afsSortLevel
End Enum
Private Type DataFilterCriterias
Field As Variant
Criterias As Variant
End Type
Private Type DataFilterFields
Added As Boolean
Operator As XlAutoFilterOperator
Fields() As DataFilterCriterias
End Type
Private Type DataSortLevel
Line As Long
SortOn As XlSortOn
SortDescending As Boolean
End Type
Private Type TypeArguments
timer As Single
Action As Long
direction As Long
Target As Variant
address As String
caller As Range
formula As String
Operator As XlAutoFilterOperator
DisibleDropDown As Boolean
SubField As Variant
Title As Variant
actionFT As XlFilterAction
CriteriaRange As Range
CopyToRange As Range
Unique As Boolean
resultArray As Variant
Cells As Range
DataCells 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
SortLevels() As DataSortLevel
Criterias() As DataFilterFields
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 ftFid(ByVal byField As Variant, ParamArray Criterias()): ftFid = vbBack: AddArgumentsFilter afsAddField, byField, Criterias: End Function
Function iAnd(ParamArray Fields()): iAnd = vbBack: AddArgumentsFilter afsOperator, Fields, xlAnd: End Function
Function iOr(ParamArray Fields()): iOr = vbBack: AddArgumentsFilter afsOperator, Fields, xlOr: End Function
Function iTop10Items(ParamArray Fields()): iTop10Items = vbBack: AddArgumentsFilter afsOperator, Fields, xlTop10Items: End Function
Function iTop10Percent(ParamArray Fields()): iTop10Percent = vbBack: AddArgumentsFilter afsOperator, Fields, xlTop10Percent: End Function
Function iBottom10Items(ParamArray Fields()): iBottom10Items = vbBack: AddArgumentsFilter afsOperator, Fields, xlBottom10Items: End Function
Function iBottom10Percent(ParamArray Fields()): iBottom10Percent = vbBack: AddArgumentsFilter afsOperator, Fields, xlBottom10Percent: End Function
Function iFilterAutomaticFontColor(ParamArray Fields()): iFilterAutomaticFontColor = vbBack: AddArgumentsFilter afsOperator, Fields, xlFilterAutomaticFontColor: End Function
Function iFilterCellColor(ParamArray Fields()): iFilterCellColor = vbBack: AddArgumentsFilter afsOperator, Fields, xlFilterCellColor: End Function
Function iFilterDynamic(ParamArray Fields()): iFilterDynamic = vbBack: AddArgumentsFilter afsOperator, Fields, xlFilterDynamic: End Function
Function iFilterFontColor(ParamArray Fields()): iFilterFontColor = vbBack: AddArgumentsFilter afsOperator, Fields, xlFilterFontColor: End Function
Function iFilterIcon(ParamArray Fields()): iFilterIcon = vbBack: AddArgumentsFilter afsOperator, Fields, xlFilterIcon: End Function
Function iFilterNoFill(ParamArray Fields()): iFilterNoFill = vbBack: AddArgumentsFilter afsOperator, Fields, xlFilterNoFill: End Function
Function iFilterNoIcon(ParamArray Fields()): iFilterNoIcon = vbBack: AddArgumentsFilter afsOperator, Fields, xlFilterNoIcon: End Function
Function iFilterValues(ParamArray Fields()): iFilterValues = vbBack: AddArgumentsFilter afsOperator, Fields, xlFilterValues: End Function
'-------------------------------------------------------------------------------------------------------
Function FilterA(ByVal DataCells As Range, ParamArray arguments()) As Variant
FilterA = AddArgumentsFilter(afsMainFXAutoFilter, DataCells)
End Function
Function fatDisibleDropDown() As String
AddArgumentsFilter afsDisibleDropDown, False
End Function
Function fatSubField(SubField As Variant) As Variant
AddArgumentsFilter afsSubField, SubField
End Function
'-------------------------------------------------------------------------------------------------------
'=AutoFilter(B4:AF24,C4:C24,ftField(1),ftCriteria1(">="&C1),ftCriteria2("<="&C2),ftxAnd())
Function FilterV(ByVal DataCells As Range, ParamArray arguments()) As Variant
FilterV = AddArgumentsFilter(afsMainFXAdvancedFilter, DataCells)
End Function
Function favCriterias(ByVal Cells As Range): Call AddArgumentsFilter(afsCriteriaRange, Cells): End Function
Function favCopyTo(ByVal Cell As Range): Call AddArgumentsFilter(afsCopyToRange, Cell): End Function
Function favUnique(): Call AddArgumentsFilter(afsUnique, True): End Function
'-------------------------------------------------------------------------------------------------------
Function AutoSort(ParamArray arguments()) As Variant: Call AddArgumentsFilter(afsFilterSort, arguments): End Function
Function ftTitle(Title As String) As String: AddArgumentsFilter afsTitle, Title: End Function
Function SortLevel(Column%, Optional SortOn As XlSortOn = xlSortOnValues, Optional SortDescending As Boolean)
AddArgumentsFilter afsSortLevel, Column, SortOn, SortDescending
End Function
Function SortCustom(ParamArray Customs()): AddArgumentsFilter afsSortCustom, Customs: End Function
Function SortDescending(): AddArgumentsFilter afsSortDescending, True: End Function
Function SortOn(Optional vSortOn As XlSortOn = xlSortOnValues): AddArgumentsFilter afsSortOn, vSortOn: End Function
Function SortDataOption(Optional DataOption As XlSortDataOption = xlSortNormal): AddArgumentsFilter afsSortDataOption, DataOption: End Function
Function SortNotHeader(): AddArgumentsFilter afsSortNotHeader, False: End Function
Function SortMatchCase(): AddArgumentsFilter afsSortMatchCase, True: End Function
Function SortLeftToRight(): AddArgumentsFilter afsSortOrientation, True: End Function
Function SortMethod(Optional Method As XlSortMethod = xlPinYin): AddArgumentsFilter afsSortMethod, Method: End Function
'-------------------------------------------------------------------------------------------------------
Function sdSortOnValues() As XlSortOn: sdSortOnValues = xlSortOnValues: End Function
Function sdSortOnCellColor() As XlSortOn: sdSortOnCellColor = xlSortOnCellColor: End Function
Function sdSortOnFontColor() As XlSortOn: sdSortOnFontColor = xlSortOnFontColor: End Function
Function sdSortOnIcon() As XlSortOn: sdSortOnIcon = xlSortOnIcon: End Function
Private Function AddArgumentsFilter(direction%, ParamArray arguments())
On Error Resume Next
Dim k%, i%, j%, 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 "*Filter[AaVv](*" 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:
If direction = afsMainFXAutoFilter Then
.Action = 4: AddArgumentsFilter = .resultArray: Call SetTimer(Application.Hwnd, 1113, 0, AddressOf S_FilterA_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
.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 afsTitle: .Title = arguments(0)
Case afsMainFXAdvancedFilter: .timer = timer: .Action = 2: .direction = direction: Set .DataCells = arguments(0): AddArgumentsFilter = "[FilterV]": Call FilterSetTimer
Case afsMainFXAutoFilter: .direction = direction: AddArgumentsFilter = "[FilterA]"
.Action = 2
.OnUndo = Application.CommandBars("Standard").Controls("&Undo").List(1) = "Filter"
'If .OnUndo Then
'Else
.timer = timer: Set .DataCells = arguments(0): Call FilterSetTimer
' End If
Case afsCriteriaRange: Set .CriteriaRange = arguments(0)
Case afsCopyToRange: Set .CopyToRange = arguments(0)
Case afsUnique: .Unique = True
Case afsDisibleDropDown: .DisibleDropDown = True
Case afsSubField: .SubField = arguments(0)
Case afsFilterSort: .FilterSort = True
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 = xlLeftToRight
Case afsSortLevel: i = 0: i = UBound(.SortLevels): i = i + 1: ReDim Preserve .SortLevels(1 To i): With .SortLevels(i): .Line = arguments(0): .SortOn = arguments(1): .SortDescending = True: End With
Case afsAddField:
i = 0: i = UBound(.Criterias):
If i > 0 Then
If .Criterias(i).Added Then GoTo addf
Else
addf: i = i + 1: ReDim Preserve .Criterias(1 To i)
End If
With .Criterias(i)
j = UBound(.Fields): j = j + 1: ReDim Preserve .Fields(1 To j)
With .Fields(j)
If IsObject(arguments(0)) Then Set .Field = arguments(0) Else .Field = arguments(0)
.Criterias = arguments(1)
End With
End With
Case afsOperator:
i = 0: i = UBound(.Criterias):
With .Criterias(i): .Operator = arguments(1): .Added = True: End With
End Select
If .Title <> Empty Then AddArgumentsFilter = .Title
End With
End Function
''///////////////////////////////////////////////////////
Private Sub FilterSetTimer()
Call SetTimer(Application.Hwnd, 1111, 0, AddressOf S_FilterA_callback)
End Sub
#If VBA7 And Win64 Then
Private Sub S_FilterA_callback(ByVal Hwnd^, ByVal uMsg&, ByVal nIDEvent&, ByVal dwTimer&)
#Else
Private Sub S_FilterA_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_FilterA_working
Case 1113:
Dim k%, i%, j%
k = UBound(Works):
For i = 1 To k
If Works(i).Action = 4 Then j = j + 1: Debug.Print j; k
Next
If j = k Then Erase Works
End Select
End Sub
'https://learn.microsoft.com/en-us/office/vba/api/excel.range.sort?source=recommendations
Private Sub S_FilterA_working()
On Error Resume Next
Dim s$
s = Application.CommandBars("Standard").Controls("&Undo").List(1)
Debug.Print "FilterA_working: " ' s
'If s = "Filter" Then Erase Works: Exit Sub
'If ThisWorkbook.BookJustSaved Then Erase Works: Exit Sub
Dim ub As Integer, a As Object, b As TypeArguments, i&, k&, kf%, lr&, lc&, cfl%, ift%, ccl%, icl%, cl%, il%, R1&, su As Boolean, ac As Boolean, ee As Boolean, v As Variant, rg As Range, Cell
ub = UBound(Works)
Dim o, sh, shf As Object, bk As Object, cri1, cri2, ope As Variant, Field, f$
Dim crs As DataFilterCriterias, fls As DataFilterFields
For i = 1 To ub
b = Works(i)
If b.Action <> 2 Then GoTo n
'If b.OnUndo Then Works(i).Action = 3: GoTo n
If b.XLNew Then f = b.caller.Formula2 Else f = b.caller.formula
If f <> b.formula Then GoTo n
If a Is Nothing Then
Set a = Application
Set bk = b.caller.parent.parent
'GoSub sh
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.DataCells: Set sh = rg.parent
Select Case b.direction
Case afsMainFXAutoFilter: GoSub AutoFilter
Case afsMainFXAdvancedFilter: GoSub AdvancedFilter
End Select
Works(i).Action = 3
n:
Next
E:
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
Exit Sub
AdvancedFilter:
'Action:=xlFilterCopy
If b.CopyToRange.CountLarge > 1 Then
Set Cell = b.CopyToRange
Else
Set Cell = b.CopyToRange(1, 1).Resize(b.DataCells.rows.count, b.DataCells.Columns.count)
End If
AreaClearContents Cell, 1, clearStyles:=True
b.DataCells.AdvancedFilter Action:=2, CriteriaRange:=b.CriteriaRange, CopyToRange:=Cell, Unique:=b.Unique
Return
AutoFilter:
If Not sh.AutoFilter Is Nothing Then sh.AutoFilter.Sort.SortFields.Clear: sh.AutoFilter.ShowAllData
cfl = UBound(b.Criterias): lr = 1
For ift = 1 To cfl
fls = b.Criterias(ift)
ccl = UBound(fls.Fields)
ope = fls.Operator
For icl = 1 To ccl
crs = fls.Fields(icl)
If IsObject(crs.Field) Then Field = 1: Set Cell = crs.Field Else Field = crs.Field: Set Cell = b.DataCells
cl = UBound(crs.Criterias)
For il = 0 To cl
kf = kf + 1
cri1 = crs.Criterias(il): cri2 = Empty
If il + 1 <= cl Then cri2 = crs.Criterias(il + 1): il = il + 1
If IsEmpty(cri2) Then
If IsEmpty(b.SubField) Then
Cell.FilterA Field:=Field, Criteria1:=cri1, Operator:=ope, VisibleDropDown:=Not b.DisibleDropDown
Else
Cell.FilterA Field:=Field, Criteria1:=cri1, Operator:=ope, VisibleDropDown:=Not b.DisibleDropDown, SubField:=b.SubField
End If
Else
If IsEmpty(b.SubField) Then
Cell.FilterA Field:=Field, Criteria1:=cri1, Operator:=ope, Criteria2:=cri2, VisibleDropDown:=Not b.DisibleDropDown
Else
Cell.FilterA Field:=Field, Criteria1:=cri1, Operator:=ope, Criteria2:=cri2, VisibleDropDown:=Not b.DisibleDropDown, SubField:=b.SubField
End If
End If
Next
Next
Err.Clear
If b.FilterSort And kf = 1 Then GoSub FilterSort
b.DataCells.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy b.caller(lr + 1, 1)
If Err = 0 Then lr = b.caller.End(xlDown).Row - b.caller.Row + 1
If Not sh.AutoFilter Is Nothing Then sh.AutoFilter.Sort.SortFields.Clear: sh.AutoFilter.ShowAllData
Next
If b.FilterSort And kf > 1 Then
lc = b.DataCells.Columns.count
GoSub CellSort
End If
If Not sh.AutoFilter Is Nothing Then sh.AutoFilter.Sort.SortFields.Clear: sh.AutoFilter.ShowAllData
lr = b.DataCells.rows.count
Set Cell = b.DataCells(1, 1).MergeArea
R1 = Cell.rows.count
If Not b.FilterSort Or Not b.SortHeader Then
Set Cell = b.DataCells
Else
Set Cell = b.DataCells.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
Return
CellSort:
Application.CutCopyMode = False
With sh
.Sort.SortFields.Clear
.Sort.SortFields.Add2 Key:=b.caller(2, 1).Resize(lr), SortOn:=b.SortOn, Order:=1 - b.SortDescending, DataOption:=b.SortDataOption ', CustomOrder:=0, SubField:=0
With .Sort
.SetRange b.caller(2, 1).Resize(lr, lc)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
Return
FilterSort:
Application.CutCopyMode = False
With sh.FilterA
.Sort.SortFields.Clear
.Sort.SortFields.Add2 _
Key:=b.DataCells, SortOn:=b.SortOn, Order:=1 - b.SortDescending, DataOption:=b.SortDataOption ', CustomOrder:=0, SubField:=0
With .Sort: .Header = b.SortHeader: .MatchCase = False: .Orientation = b.SortOrientation: .SortMethod = b.SortMethod: .Apply: End With
End With
Return
sh:
Err.Clear: Set shf = bk.Worksheets("__Filters__")
If Err Then
Set sh = bk.ActiveSheet
Set shf = bk.Worksheets.Add(after:=bk.Worksheets(bk.Worksheets.count))
shf.Name = "__Filters__"
sh.Activate
End If
Return
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 = "Software\Microsoft\Office\" & CStr(Application.Version) & "\Common\Licensing\LicensingNext"
rootDirectory = "."
Set registryObject = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & rootDirectory & "\root\default: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 Function
Function dd(ByVal DateTime As Date, Optional DateSeparator$ = "/") As String
Dim s$, T$: T = DateSeparator
'0 = month-day-year, 1 = day-month-year, 2 = year-month-day
Select Case Application.International(32)
Case 0: s = "mm" & T & "dd" & T & "yyyy"
Case 1, 2: s = "dd" & T & "mm" & T & "yyyy"
'Case 2: s = "yyyy" & t & "mm" & t & "dd"
End Select
If DateTime - CDate(Format(DateTime, s)) > 0 Then
dd = Format(DateTime, s & " hh:mm:ss")
Else
dd = Format(DateTime, s)
End If
End Function
Private Sub AreaClearContents(ByVal vRange As Object, Optional ByVal OffsetRow&, Optional ByVal OffsetColumn&, Optional LimitRow&, Optional LimitColumn&, Optional clearStyles As Boolean)
Dim R As Object
Set R = AreaFromTarget(vRange, OffsetRow&, OffsetColumn&, LimitRow, LimitColumn)
If Not R Is Nothing Then R.ClearContents: If clearStyles Then R.Borders.LineStyle = xlNone
End Sub
Private Function AreaFromTarget(ByVal vRange As Object, Optional ByVal OffsetRow&, Optional ByVal OffsetColumn&, Optional LimitRow&, Optional LimitColumn&) As Object
Dim R As Range, T As Range, R1&, C1&, R2&, C2&
R1 = OffsetRow: C1 = OffsetColumn: Set R = vRange(1, 1): Set T = R.CurrentRegion
If T.Cells.count > 1 Then
R2 = T.Row + T.rows.count - R.Row - R1 + 1
C2 = T.Column + T.Columns.count - R.Column - C1 + 1
If LimitRow > 0 Then R2 = IIf(LimitRow < R2, LimitRow, R2)
If LimitColumn > 0 Then C2 = IIf(LimitColumn < C2, LimitColumn, C2)
If R2 > 1 And C2 > 1 Then Set AreaFromTarget = R(R1 + 1, C1 + 1).Resize(R2, C2)
End If
End Function
Lần chỉnh sửa cuối:
