How to use AutoFilters in Excel VBA Macros (1 người xem)

[SA_DQ]

How to use AutoFilters in Excel VBA Macros
A./ Excel VBA AutoFilters

Option Explicit

[B]Sub AutoFilter()[/B]
' Macro recorded 23/09/2006
    Sheets("S0").Select:        Range("A1:B13").Select
    Selection.AutoFilter
    CheckFilter "1"
    Selection.AutoFilter Field:=2, Criteria1:="Nguyen"
    CheckFilter "2"
    Selection.AutoFilter Field:=2, Criteria1:="Tran"
    CheckFilter "3"
    ActiveSheet.ShowAllData
    Cells.Select:    Selection.AutoFilter
    CheckFilter "4"
[B]End Sub[/B]

[B]Sub CheckFilter(StrC As String)[/B]
    If ActiveSheet.AutoFilterMode = True Then
       MsgBox "They are visible", , StrC
    Else
       MsgBox "They are not visible", , StrC
    End If
[B]End Sub[/B]

[B]Sub ApplyAutoFilters()[/B]   
 With ActiveSheet
        .AutoFilterMode = False:            CheckFilter2 "1"
        .Range("A1:C1").AutoFilter:         CheckFilter2 "2"
    End With
[B]End Sub[/B]

[B]Sub CheckFilter2(StrC As String)[/B]

    With ActiveSheet
        If .AutoFilterMode = True And .FilterMode = True Then
            MsgBox "They are visible and in use", , StrC
        ElseIf .AutoFilterMode = True Then
            MsgBox "They are visible but not in use", , StrC
        Else
            MsgBox "They are not visible or in use", , StrC
        End If
    End With
[B]End Sub[/B]

[B]Sub IsAFilterCell()[/B]
On Error Resume Next
 Dim Rang As Range:         Dim StrC As String

 With ActiveSheet
    Set Rang = .AutoFilter.Range
    If .AutoFilterMode = True Then
        If Not Intersect(ActiveCell, Rang) Is Nothing Then StrC = ActiveCell.Address
        MsgBox Rang.Address, , StrC
    Else
        MsgBox "AutoFilters are not on"
    End If
 End With
[B]End Sub[/B]

[B]Sub ApplyAutoFiltersToOneCell()[/B]
	With ActiveSheet
		.AutoFilterMode = False
		.Range("A1:A2").AutoFilter
	End With
[B]End Sub[/B]

copying autofilter results intoanother worksheet

[B]Sub CopyFilter()[/B]
' Macro recorded 19/07
    Selection.AutoFilter Field:=1, Criteria1:="James"
    Range("D4:F15").Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A1").Select
    ActiveSheet.Paste
[B]End Sub[/B]

[B]Sub test() [/B]
    Columns("c:c").Delete 
     ' the above line is only for testing macro once or twice
    Range("a1").Select 
  [COLOR="Purple"]  Selection.AutoFilter Field:=1, Criteria1:=">=5", Operator:=xlAnd 
    ActiveSheet.UsedRange.Select [/COLOR]  
  Selection.SpecialCells(xlCellTypeVisible).Select 
    Dim rng As Range 
    Set rng = Selection.SpecialCells(xlCellTypeVisible) 
    MsgBox rng.Address 
    For Each c In rng 
        If c.Address = "$A$1" Then Goto line1 
        If c.Column = 2 Then Goto line1 
        c.Offset(0, 2) = c + c.Offset(0, 1) 
line1: 
    Next c 
    Range("a1").Select 
    Selection.AutoFilter 
    MsgBox "macro is over" 
[B]End Sub[/B]

[B]Sub AutomateIt() [/B]
    Dim ws As Worksheet 
    Dim LastRow As Long 
    Set ws = ThisWorkbook.Worksheets("Sheet1") 
    LastRow = ws.Range("A65536").End(xlUp).Row 
    ws.Range("A1:C" & LastRow).AutoFilter Field:=1, Criteria1:="=*0020*", Operator:=xlOr, _ 
    Criteria2:="=*1020*" 
    With ws.Range("A2:C" & LastRow) 
        ws.Range("E1").Copy Intersect(.SpecialCells(xlVisible), ws.Columns("B")) 
        ws.Range("F1").Copy Intersect(.SpecialCells(xlVisible), ws.Columns("C")) 
        .AutoFilter 
    End With 
    ws.Columns("B:C").Copy 
    ws.Columns("B:C").PasteSpecial (xlValues) 
    Application.CutCopyMode = False 
[B]End Sub[/B]

B./ Criteria for VBA AutoFilters
Đoạn mã sẽ xếp theo trường [Ho] & chọn ~ người có họ = 'Nguyễn'

[B]Sub FilterTo1Criteria()[/B]

    With Sheet1
            .AutoFilterMode = False
            .Range("A1:D1").AutoFilter
            .Range("A1:D1").AutoFilter Field:=2, Criteria1:="Nguyen"
    End With    
[B]End Sub[/B]

[B]Sub FilterTo2Criteria()[/B]

    With Sheet1
            .AutoFilterMode = False
            .Range("A1:D1").AutoFilter
            .Range("A1:D1").AutoFilter Field:=2, Criteria1:="Le", _
             Operator:=xlOr, Criteria2:="Tran"
‘            .Range("A1:D1").AutoFilter Field:=2, Criteria1:=">=35", _
‘            Operator:=xlAnd, Criteria2:="<=45"
    End With    
[B]End Sub[/B]

[B]Sub FilterTo2Fields()[/B]
 Dim StrC As String 
 StrC = "A*"
    With Sheet1
            .AutoFilterMode = False
                With .Range("A1:D1")
                     .AutoFilter
                     .AutoFilter Field:=1, Criteria1:="<a4"
                     .AutoFilter Field:=3, Criteria1:=">" & StrC
                End With
    End With    
[B]End Sub[/B]

[B]Sub FilterToShowAsterisk()[/B]
    With Sheet1
            .AutoFilterMode = False
            .Range("A1:D1").AutoFilter
'            .Range("A1:D1").AutoFilter Field:=1, Criteria1:="*"
            .Range("A1:D1").AutoFilter Field:=1, Criteria1:="~*"
    End With
[B]End Sub[/B]

[B]Sub AutofilterSyntax()[/B]
Dim NgDau, NgCuoi As Date 
 Range("F14").Select
 NgDau = ActiveCell.Value                        'txtStart.Value
 NgCuoi = ActiveCell.Offset(0, 1).Value          '  txtEnd.Value
 Range("A4").Select:     Selection.AutoFilter

 Selection.AutoFilter Field:=4, Criteria1:=">" & NgDau, Operator:=xlOr, _
    Criteria2:="<" & NgCuoi
[B]End Sub[/B]

[B]Sub CopyAfterFilter()[/B]
 On Error Resume Next
    Dim sht2, sht3, LastRow As Long
    Dim Msg As String, cRiteria As String
    Dim cell As Range, UpBound As Range, LowBound As Range, Pasterange As Range    
    Set sht3 = Sheets("S0"):     Set sht2 = Sheets("S2")
     
    Application.ScreenUpdating = False
    Sheets("S0").Unprotect
     'last row number of column to be filtered'
    LastRow = sht3.Range("D65536").End(xlUp).Row
     'Column to search down and filter out zeros'
    sht3.Range("D1:D" & LastRow).AutoFilter Field:=1, Criteria1:="<>0"
     'Automatically Select Used range excluding header'
    Set UpBound = sht3.Range("D2")
    Set LowBound = sht3.Range("D2").End(xlDown)
    Range(UpBound, LowBound).Select
    Set Pasterange = sht2.Range("B65536").End(xlUp).Offset(1, 0)     ' Copy'
    Selection.Copy Destination:=Pasterange
     '  Deactivate the Auto filter'
    sht3.Range("D1:D" & LastRow).AutoFilter
[B]End Sub[/B]

c./ Display Excel AutoFilter Criteria

[B]Function AutoFilterCriteria(Header As Range) As String[/B]
Dim StrCh1 As String, StrCh2 As String

    Application.Volatile
    With Header.Parent.AutoFilter
        
        With .Filters(Header.Column - .Range.Column + 1)
        
            If Not .On Then Exit Function
                StrCh1 = .Criteria1
            If .Operator = xlAnd Then
                StrCh2 = " AND " & .Criteria2
            ElseIf .Operator = xlOr Then
                StrCh2 = " OR " & .Criteria2
            End If
            
        End With
    End With
    AutoFilterCriteria = UCase(Header) & ": " & StrCh1 & StrCh2    
[B]End Function[/B]

d./ Excel AutoFilters in VBA Using Dates

[B]Private Sub DaySearch()[/B]
    Dim strStart, strEnd, datStart As Date, datEnd As Date
    
    Sheets("S0").Select
    strStart = Range("F27").Value:              strEnd = Range("F28").Value
    datStart = CLng(CDate(strStart)):           datEnd = CLng(CDate(strEnd))
    Range("A1:D20").Select
    
    Selection.AutoFilter Field:=4, Criteria1:=">=" & datStart, _
         Operator:=xlOr, Criteria2:="<=" & datEnd
[B]End Sub[/B]

[B]Sub FilterByDate()[/B]
Dim dDate As Date:      Dim lDate As Long
Dim strDate As String
 Sheets("S0").Select
 dDate = DateSerial(Year(Range("F27")), Month(Range("F27")), Day(Range("F27")))
 
 lDate = dDate
 MsgBox Str(lDate)
 Range("D1").AutoFilter Field:=4, Criteria1:="<" & lDate    
[B]End Sub[/B]

[B]Sub FilterByDateTime()[/B]
Dim dDate As Date
Dim dbDate As Double

If IsDate(Range("B1")) Then
    dbDate = Range("B1")
    dbDate = DateSerial(Year(dbDate), Month(dbDate), Day(dbDate)) + _
         TimeSerial(Hour(dbDate), Minute(dbDate), Second(dbDate))
   
    Range("A1").AutoFilter Field:=1, Criteria1:=">" & dbDate
End If
[B]End Sub	[/B]

[B]Sub CopyFilteredData() [/B]
    Dim StartDate As Date 
    Dim EndDate As Date 
    Dim SheetCounter As Integer 
    Dim ws As Worksheet 
     
    For SheetCounter = 2 To 3 ' change to sheets you want to cover
        Set ws = ThisWorkbook.Worksheets(SheetCounter) 
        StartDate = ws.Range("b1").Value 
        EndDate = ws.Range("b2").Value 
         
        With Worksheets("sheet1") 
            ws.Range("a3:d" & ws.Range("a65536").End(xlUp).Row).ClearContents 
            With .Range("a1:d" & .Range("a65536").End(xlUp).Row) 
                .AutoFilter Field:=1, Criteria1:=">=" & Format(StartDate, _ "m/d/yy"), Operator:=xlAnd, Criteria2:="<=" & Format(EndDate, "m/d/yy") 
                Intersect(.SpecialCells(xlCellTypeVisible), Worksheets("sheet1").Range("A:A", "C:C")).Copy ws.Range("a3")
 ' change to columns AA CC .. you want to include
            End With 
            .ShowAllData 
        End With 
    Next SheetCounter 
[B]End Sub [/B]

 

[Đào Việt Cường]

Dear SA_DQ,
------------
Em muốn góp ý thêm:
Nếu kiến thức được sưu tầm trên mạng thì anh nên bổ xung thêm thông tin "Tài nguyên" đó ở đâu. Còn nếu kiến thức anh muốn chia sẻ thì cần giải thích rõ từng đoạn code minh hoạ (mục đích, công dụng, cách thức...). Theo em nên nêu cú pháp và cách dùng để mọi người vận dụng trước hơn là đưa ra các ví dụ đơn lẻ. Chẳng hạn, mẩu thông tin trợ giúp dưới đây cũng có thể giúp chúng ta hiểu rất nhiều về phương thức này:

AutoFilter Method

Filters a list using the AutoFilter. Variant.

Note Apply the AutoFilter property to a Worksheet object to return an AutoFilter object.

expression.AutoFilter(Field, Criteria1, Operator, Criteria2, VisibleDropDown)
expression Required. An expression that returns one of the objects in the Applies To list.
Field Optional Variant. The integer offset of the field on which you want to base the filter (from the left of the list; the leftmost field is field one).
Criteria1 Optional Variant. The criteria (a string; for example, "101"). Use "=" to find blank fields, or use "<>" to find nonblank fields. If this argument is omitted, the criteria is All. If Operator is xlTop10Items, Criteria1 specifies the number of items (for example, "10").
Operator Optional XlAutoFilterOperator.
XlAutoFilterOperator can be one of these XlAutoFilterOperator constants.xlAnd defaultxlBottom10ItemsxlBottom10PercentxlOrxlTop10ItemsxlTop10PercentUse xlAnd and xlOr with Criteria1 and Criteria2 to construct compound criteria.

Criteria2 Optional Variant. The second criteria (a string). Used with Criteria1 and Operator to construct compound criteria.
VisibleDropDown Optional Variant. True to display the AutoFilter drop-down arrow for the filtered field. False to hide the AutoFilter drop-down arrow for the filtered field. True by default.
Remarks

If you omit all the arguments, this method simply toggles the display of the AutoFilter drop-down arrows in the specified range.
Example

This example filters a list starting in cell A1 on Sheet1 to display only the entries in which field one is equal to the string "Otis". The drop-down arrow for field one will be hidden.
Worksheets("Sheet1").Range("A1").AutoFilter _ field:=1, _ Criteria1:="Otis" VisibleDropDown:=False

 

[Mr Okebab]

Tiếp nữa đi anh SA_DQ ơi.

 

[HảiĐăng]

Đồng ý với MrHieu
Mình xem lướt qua đoạn code của SA_DQ (chưa copy để thử)
mình hiểu rằng đó là đoạn mã do SA_DQ ghi để phục vụ cho công việc của riêng mình, Với người làm việc trong bối cảnh khác thì chỉ có nước ...

 

[SA_DQ]

)-(ết rồi, chuyên đề chỉ có vậy!

Tiếp nữa đi anh SA_DQ ơi.

To HảiĐăng: /(hông phải như HĐăng nghỉ đâu, đây là nguồn trên một diễn đàn Và mình chép ~ gì diễn đàn ấy nói về Filter = VBA, thấy hay thì thử nghiệm & đưa lên đây thôi!
/(/)ẹo: Vô tìm kiếm & nhập filter nó sẽ ra khoảng vài trăm bài nghiên cứu;
Bài nào ưng í thì copy & thử. . . Để đâu đó thì khó nhớ; mới nhờ GPE giữ giùm ý mà!
(Nói nhỏ chứ không bị SMod Cường đuổi đi bây chừ!)

 

[Mr Okebab]

(Nói nhỏ chứ không bị SMod Cường đuổi đi bây chừ!)

He he he, ai lại nghĩ xấu về A Cường như thế, hơn nữa cũng vì cộng đồng nên anh ấy không chấp đâu.

Anh SA_DQ ơi, sao lại mang con bỏ chợ vậy, đang hăng say đọc thì hết cái rụp. Chán thật, search thì nhiều nhưng có người đi trước chọn lọc thì tốt hơn rất nhiều.