Hàm FilterA và FilterV - Tận dụng bộ lọc AutoFilter và AdvancedFilter

Liên hệ QC

HeSanbi

Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨
Tham gia
24/2/13
Bài viết
2,553
Được thích
3,884
Giới tính
Nam
HÀM UDF FilterA 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 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 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
Hai Pattern trong điều kiện so sánh là ?*:
  • ? 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 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
DataCellsVù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
DataCellsVù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​
favUniqueLọ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()Đặt sắp xếp chiều ngược lại
SortMatchCase()Đặ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 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:
Cảm ơn bác nhiều lắm ạ
Với mẫu dưới đây,
Em muốn lọc 1: Các bản ghi thỏa mãn điều kiện cột Date2 là ngày 17/02/2025 và Cột TPG không phải là KK
Em muốn lọc 2: Các bản ghi thỏa mãn điều kiện cột Date2 là từ ngày 21/02/2025 trở đi và Cột TPG không phải là KK
Thì phải viết thế nào trong công thức autofilter ạ (kết quả lọc hiện dưới chỗ gõ hàm autofilter)
AABBBCCCCXXXXMMMTTTTQQQQDate1Date2TPDTPG
01Aabc
100.000.000,00​
EURVND23.800,00238.000.000.00017/02/202117/02/2025BVSSHORE
01Bxyz
100.000.000,00​
EURVND23.801,04-238.010.400.00017/02/202117/02/2025KKKK
02Akkx
100.000.000,00​
EURVND23.800,00238.000.000.00017/02/202117/02/2025BVSSHORE
02Bnnn
100.000.000,00​
EURVND23.801,04-238.010.400.00017/02/202117/02/2025SHOREBVS
03ahhh
100.000.000,00​
EURVND23.800,00238.000.000.00017/02/202117/02/2025BVSSHORE
03buuu
100.000.000,00​
EURVND23.801,04-238.010.400.00017/02/202120/02/2025SHOREBVS
04accc
100.000.000,00​
EURVND23.800,00238.000.000.00017/02/202120/02/2025BVSSHORE
04bggg
100.000.000,00​
EURVND23.801,04-238.010.400.00017/02/202120/02/2025SHOREBVS
05ahsg
100.000.000,00​
EURVND23.800,00238.000.000.00017/02/202117/02/2025BVSSHORE
05brrrr
100.000.000,00​
EURVND23.801,04-238.010.400.00017/02/202117/02/2025SHOREBVS
06Aabc
100.000.000,00​
EURVND23.800,00119.000.000.00017/02/202117/02/2025BVSSHORE
06Bxyz
100.000.000,00​
EURVND23.801,04-119.005.200.00017/02/202121/02/2025SHOREBVS
07Akkx
100.000.000,00​
EURVND23.800,00238.000.000.00017/02/202127/02/2025BVSSHORE
07Bnnn
100.000.000,00​
EURVND23.801,04-238.010.400.00017/02/202125/02/2025SHOREBVS
08Ahhh
100.000.000,00​
EURVND23.800,00238.000.000.00017/02/202117/02/2025BVSSHORE
08Buuu
100.000.000,00​
EURVND23.801,04-238.010.400.00017/02/202117/02/2025SHOREBVS
09Accc
100.000.000,00​
EURVND23.800,00238.000.000.00017/02/202117/02/2025BVSSHORE
09Bggg
100.000.000,00​
EURVND23.801,04-238.010.400.00017/02/202117/02/2025SHOREBVS
10Ahsg
100.000.000,00​
EURVND23.800,00238.000.000.00017/02/202117/02/2025BVSSHORE
10Brrrr
100.000.000,00​
EURVND23.801,04-238.010.400.00017/02/202117/02/2025SHOREBVS
11xxxx
100.000.000,00​
EURVND23.800,00214.200.000.00017/02/202117/02/2025KKKK
 
Lần chỉnh sửa cuối:
Upvote 0
Cảm ơn bác nhiều lắm ạ
Với mẫu dưới đây,
Em muốn lọc 1: Các bản ghi thỏa mãn điều kiện cột Date2 là ngày 17/02/2025 và Cột TPG không phải là KK
Em muốn lọc 2: Các bản ghi thỏa mãn điều kiện cột Date2 là từ ngày 21/02/2025 trở đi và Cột TPG không phải là KK
Thì phải viết thế nào trong công thức autofilter ạ (kết quả lọc hiện dưới chỗ gõ hàm autofilter)


Bác chờ bản cập nhật tiếp theo, sẽ có phương thức trích dữ liệu nhiều điều kiện. Cho cả AutoFilter và AdvancedFilter
 
Upvote 0
Quả là code khủng. Nội việc làm sao điền tham số cho đúng thôi cũng đã phờ rồi.
 
Upvote 0
Quả là code khủng. Nội việc làm sao điền tham số cho đúng thôi cũng đã phờ rồi.
Em rất ngưỡng mộ code của bác ấy. Tuy nhiên thú thật không học được thêm gì vì em kém quá, gần như chả code nào em hiểu được. Nguyên việc chỉnh sửa để phù hợp với mình cũng quá khó rồi...
 
Upvote 0
Em rất ngưỡng mộ code của bác ấy. Tuy nhiên thú thật không học được thêm gì vì em kém quá, gần như chả code nào em hiểu được. Nguyên việc chỉnh sửa để phù hợp với mình cũng quá khó rồi...
Advanced filter của excel có sẵn làm được hết những việc ấy. Và cũng phải học 1 chút. Tuy vậy học cái có sẵn tiện lợi hơn ở chỗ qua máy nào cũng biết xài, cài đặt lại windows, office không phải cài thêm hoặc copy code thêm.
 
Upvote 0
Cảm ơn bác nhiều lắm ạ
Với mẫu dưới đây,
Em muốn lọc 1: Các bản ghi thỏa mãn điều kiện cột Date2 là ngày 17/02/2025 và Cột TPG không phải là KK
Em muốn lọc 2: Các bản ghi thỏa mãn điều kiện cột Date2 là từ ngày 21/02/2025 trở đi và Cột TPG không phải là KK
Thì phải viết thế nào trong công thức autofilter ạ (kết quả lọc hiện dưới chỗ gõ hàm autofilter)
AABBBCCCCXXXXMMMTTTTQQQQDate1Date2TPDTPG
01Aabc
100.000.000,00​
EURVND23.800,00238.000.000.00017/02/202117/02/2025BVSSHORE
01Bxyz
100.000.000,00​
EURVND23.801,04-238.010.400.00017/02/202117/02/2025KKKK
02Akkx
100.000.000,00​
EURVND23.800,00238.000.000.00017/02/202117/02/2025BVSSHORE
02Bnnn
100.000.000,00​
EURVND23.801,04-238.010.400.00017/02/202117/02/2025SHOREBVS
03ahhh
100.000.000,00​
EURVND23.800,00238.000.000.00017/02/202117/02/2025BVSSHORE
03buuu
100.000.000,00​
EURVND23.801,04-238.010.400.00017/02/202120/02/2025SHOREBVS
04accc
100.000.000,00​
EURVND23.800,00238.000.000.00017/02/202120/02/2025BVSSHORE
04bggg
100.000.000,00​
EURVND23.801,04-238.010.400.00017/02/202120/02/2025SHOREBVS
05ahsg
100.000.000,00​
EURVND23.800,00238.000.000.00017/02/202117/02/2025BVSSHORE
05brrrr
100.000.000,00​
EURVND23.801,04-238.010.400.00017/02/202117/02/2025SHOREBVS
06Aabc
100.000.000,00​
EURVND23.800,00119.000.000.00017/02/202117/02/2025BVSSHORE
06Bxyz
100.000.000,00​
EURVND23.801,04-119.005.200.00017/02/202121/02/2025SHOREBVS
07Akkx
100.000.000,00​
EURVND23.800,00238.000.000.00017/02/202127/02/2025BVSSHORE
07Bnnn
100.000.000,00​
EURVND23.801,04-238.010.400.00017/02/202125/02/2025SHOREBVS
08Ahhh
100.000.000,00​
EURVND23.800,00238.000.000.00017/02/202117/02/2025BVSSHORE
08Buuu
100.000.000,00​
EURVND23.801,04-238.010.400.00017/02/202117/02/2025SHOREBVS
09Accc
100.000.000,00​
EURVND23.800,00238.000.000.00017/02/202117/02/2025BVSSHORE
09Bggg
100.000.000,00​
EURVND23.801,04-238.010.400.00017/02/202117/02/2025SHOREBVS
10Ahsg
100.000.000,00​
EURVND23.800,00238.000.000.00017/02/202117/02/2025BVSSHORE
10Brrrr
100.000.000,00​
EURVND23.801,04-238.010.400.00017/02/202117/02/2025SHOREBVS
11xxxx
100.000.000,00​
EURVND23.800,00214.200.000.00017/02/202117/02/2025KKKK
Bài này của bạn tôi nghĩ là bài dùng công cụ Advanced Filter cơ bản.
Cũng không nên quá phức tạp Hàm tự tạo làm chi, công cụ AF là cơ bản và quá mạnh mẽ rồi.
Các code trong Module là tôi chỉ Record macro, với các điều kiện lọc như bạn đưa ra.
Bạn xem File, kích vào nút Câu 1 hoặc Câu 2
 

File đính kèm

  • TraLoi.xlsm
    21 KB · Đọc: 31
Upvote 0
Bài này của bạn tôi nghĩ là bài dùng công cụ Advanced Filter cơ bản.
Cũng không nên quá phức tạp Hàm tự tạo làm chi, công cụ AF là cơ bản và quá mạnh mẽ rồi.
Các code trong Module là tôi chỉ Record macro, với các điều kiện lọc như bạn đưa ra.
Bạn xem File, kích vào nút Câu 1 hoặc Câu 2
Em cảm ơn bác nhiều ạ!!!
 
Upvote 0
Bài này của bạn tôi nghĩ là bài dùng công cụ Advanced Filter cơ bản.
Cũng không nên quá phức tạp Hàm tự tạo làm chi, công cụ AF là cơ bản và quá mạnh mẽ rồi.
Các code trong Module là tôi chỉ Record macro, với các điều kiện lọc như bạn đưa ra.
Bạn xem File, kích vào nút Câu 1 hoặc Câu 2
Bác ơi, em muốn coppy kết quả lọc được vào 1 vị trí nào đấy của sheet khác thì viết thêm vào như thế nào ạ
 
Upvote 0
em đang muốn cái đấy nhưng loay hay chưa biết làm thế nào bác
Ví dụ bạn muốn copy qua vùng B4:L4 của sheet2 (chiều ngang bằng với vùng O4:Y4 như code trong file) thì sửa chỗ này:
CopyToRange:=Range("O4:Y4")
thành:
CopyToRange:=Sheets("Sheet2").Range("B4:L4")
 
Upvote 0
Ví dụ bạn muốn copy qua vùng B4:L4 của sheet2 (chiều ngang bằng với vùng O4:Y4 như code trong file) thì sửa chỗ này:
CopyToRange:=Range("O4:Y4")
thành:
CopyToRange:=Sheets("Sheet2").Range("B4:L4")
Vâng, cảm ơn bác nhé
Bài đã được tự động gộp:

Ví dụ bạn muốn copy qua vùng B4:L4 của sheet2 (chiều ngang bằng với vùng O4:Y4 như code trong file) thì sửa chỗ này:
CopyToRange:=Range("O4:Y4")
thành:
CopyToRange:=Sheets("Sheet2").Range("B4:L4")
Copy như thế này là coppy cả ô trống ah bác, em chỉ muốn coppy phần kết quả lọc được thôi, vì copy cả ô trống thì nó đè lên dữ liệu phần bên dưới của sheet2 ạ
 
Lần chỉnh sửa cuối:
Upvote 0
Vâng, cảm ơn bác nhé
Bài đã được tự động gộp:


Copy như thế này là coppy cả ô trống ah bác, em chỉ muốn coppy phần kết quả lọc được thôi, vì copy cả ô trống thì nó đè lên dữ liệu phần bên dưới của sheet2 ạ
Vậy thì giữ nguyên câu lệnh cũ, thêm dòng này vào bên dưới:
Range("O4:Y" & Range("O" & Rows.Count).End(xlUp).Row).Copy Sheets("Sheet2").Range("B4")
 
Upvote 0
Vậy thì giữ nguyên câu lệnh cũ, thêm dòng này vào bên dưới:
Range("O4:Y" & Range("O" & Rows.Count).End(xlUp).Row).Copy Sheets("Sheet2").Range("B4")
bác sửa vào cái code này cho em được không ạ, em sửa vào kiểu gì nó cứ bị báo lỗi ạ. Cảm ơn bác
Sub TraLoi01()
Range("B4:L25").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"O1: P2"), CopyToRange:=Range("O4:Y4"), Unique:=False
End Sub
Sub TraLoi02()
Range("B4:L25").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"S1:T2"), CopyToRange:=Range("O4:Y4"), Unique:=False
End Sub
 
Upvote 0
bác sửa vào cái code này cho em được không ạ, em sửa vào kiểu gì nó cứ bị báo lỗi ạ. Cảm ơn bác
Sub TraLoi01()
Range("B4:L25").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"O1: P2"), CopyToRange:=Range("O4:Y4"), Unique:=False
End Sub
Sub TraLoi02()
Range("B4:L25").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"S1:T2"), CopyToRange:=Range("O4:Y4"), Unique:=False
End Sub
Chắc bạn sai tên sheet rồi, chỗ Sheets("Sheet2").Range("B4") phải thay Sheet2 bằng tên sheet của bạn.
Tôi kèm file có chèn thêm sheet2 đây
 

File đính kèm

  • TraLoi.xlsm
    23 KB · Đọc: 11
Upvote 0
Chắc bạn sai tên sheet rồi, chỗ Sheets("Sheet2").Range("B4") phải thay Sheet2 bằng tên sheet của bạn.
Tôi kèm file có chèn thêm sheet2 đây
Em ấn "Câu 2" không copy sang sheet 2 bác a hay là do chưa clear kết quả cũ bác nhỉ. Với lại em hỏi chút là định vị, vị trí paste sang sheets 2 (vẫn đầy đủ kết quả lọc ra) nếu không bắt đầu từ phải bắt đầu tư B4 của sheet 2 mà bắt đầu từ C5 của sheet thì sửa lại thế nào ạ
 
Lần chỉnh sửa cuối:
Upvote 0
Web KT

Bài viết mới nhất

Back
Top Bottom