headerbanner

VBA - AutoFilter a datum (2)

AutoFilter and Date Type (VBA Excel)

Při programovém nastavení kritérií automatického filtru se objekt AutoFilter chová poněkud nepředvídatelně při proměnných s datovým formátem. Příklady dále uvedených funkcí ošetřují jak tento problém, tak nastavení filtru v běžných případech, tedy pro textové, číselné i logické hodnoty bez ohledu na jejich počet.

Metoda nastavující vlastnosti filtru vypadá následovně:

expression.AutoFilter(Field, Criteria1, Operator, Criteria2, VisibleDropDown)
 

Pokud jsou filtrovaná data typu date a je jich víc než dvě, pak je pole s hodnotami filtru potřeba uložit do vlastnosti .Criteria2, zatímco v ostatních případech do .Criteria1.

V příkladu jsou popsané funkce, z nichž první nastavuje hodnoty fitrů vrácené druhou funkcí. Lze to použít při obnově uživatelem nastaveného filtrování či při přenosu takového nastavení do nového listu a pod.

Pokud je například v tabulce zapnutý AutoFilter a potřebujete uchovat hodnoty, nastavené uživatelem, použijete druhou funkci. Uchová hodnoty v kolekci, která jako parametr druhé funkce umožní obnovit nastavené filtrování.

Všimněte si úpravy tvaru datumu, která je potřebná pro český Excel. Podobně pro češtinu je potřebná úprava u logických hodnot ve filtru (asi by šlo použít i nějakých funkcí listu, které si poradí s hodnotami PRAVDA a NEPRAVDA místo True a False, ale to už se mi nechtělo zkoušet).

Funkce getAutofilterPar by se po modifikaci dala použít i pro přípravu dat místo pro kopírování uživatelského nastavení fitru. Jen je potřeba zachovat tvar pole pro setAutofilterPar. Je to pole kolekcí, počet prvků tohoto pole je rovný počtu fitrovaných sloupců. Každá kolekce má členy:

  • "operator": =.operator
  • "crit" (nebo "critdate"): =Array(.Criteria1,.Criteria2)
  • "onoff": =.On

Funkce GetIndex je pomocná funkce pro zjištění přítomnosti a polohy prvku pole. Tvar zkušební tabulky, na které bylo testováno makro example(), najdete na konci textu.

How to preserve and set filter criteria

Option Explicit
Public Function getAutofilterPar(tabname As String) As Variant
'#############################################################
'It gets autofilter params in table tabname
'allFilters is array of collections, the members of collection are "onoff","operator" and "crit" od "critdate"
'returns allFilters
'#############################################################
'Resources:
'http://answers.microsoft.com/en-us/office/forum/office_2007-customize/get-run-time-error-1004-when-addressing-filtering/8436bdf6-3461-401d-bce9-2590412c6202
'http://www.computing.net/answers/office/rolling-date-in-a-macro/14945.html
'http://www.ozgrid.com/forum/showthread.php?t=19679
Dim allFilters() As Collection 'collection of filter values
Dim OneFilter As Collection 'one filter collection
Dim filcount As Integer, firstrow As Long, lastrow As Long, firstcol As Long, lastcol As Long
Dim arrfil() As Variant, arrfil2() As Variant
Dim i, j, k, l
Dim toplim As Long
Dim lastviscell As Range, visrange As Range
Dim visr As Variant, dateTemp As Variant, cri As Variant
Dim ubnew As Long
Const MySingleSelection As Variant = Empty
With Sheets(tabname)
    If .AutoFilterMode Then
        With .AutoFilter
            filcount = .Filters.Count
'            firstrow = .Range.Row
'            lastrow = firstrow - 1 + .Range.Rows.Count
            firstcol = .Range.Column
        End With
        lastcol = firstcol - 1 + filcount
        ReDim allFilters(1 To filcount)
        'pass through all filters
        For i = 1 To filcount
            With .AutoFilter.Filters(i)
                Set OneFilter = New Collection
                OneFilter.Add .On, "onoff"
                If .On Then 'only if a filter is on
                    OneFilter.Add .Operator, "operator"
                    If .Operator = MySingleSelection Then 'one criterion
                        OneFilter.Add Array(.Criteria1), "crit"
                    ElseIf .Operator = xlOr Then
                        OneFilter.Add Array(.Criteria1, .Criteria2), "crit"
                    ElseIf .Operator = xlFilterValues Then
                        On Error Resume Next
                        toplim = UBound(.Criteria1)
                        If Err.Number > 0 Then
                            Err.Clear
                            If UBound(.Criteria2) And False Then
                                '.Criteria1 and .Criteria2 N/A - list from a range
                                Err.Clear
                                With Sheets(tabname)
                                    Set lastviscell = .Cells(Rows.Count, .AutoFilter.Range.Column).Offset(0, i - 1).End(xlUp)
                                    Set visrange = Range(Cells(.AutoFilter.Range.Row + 1, _
                                    .AutoFilter.Range.Column).Offset(0, i - 1), lastviscell.Offset(1, 0)).SpecialCells(xlCellTypeVisible)
                                    'arrfilx = WorksheetFunction.Transpose(visrange) / you can't use Transpose() for an interrupted range
                                    ReDim arrfil(visrange.Count - 1)
                                    j = 0
                                    For Each visr In visrange
                                        If GetIndex(arrfil, CDate(visr.Value)) = -1 Then 'value only once
                                            arrfil(j) = IIf(TypeName(visr.Value) = "Date", CDate(visr.Value), visr.Value)
                                            j = j + 1
                                        End If
                                    Next
                                    ReDim Preserve arrfil(j - 1)
                                    'Sort ascending arrfil
                                    For k = 0 To UBound(arrfil) - 1
                                        For l = 0 To UBound(arrfil) - 1
                                            If arrfil(l) > arrfil(l + 1) Then
                                              dateTemp = arrfil(l)
                                              arrfil(l) = arrfil(l + 1)
                                              arrfil(l + 1) = dateTemp
                                            End If
                                        Next l
                                    Next k
                                    ReDim Preserve arrfil(j - 1)
                                    'ReDim arrfil2() to one based array and _
                                     multiply by 2 to allow for 2 to be inserted _
                                     as alternative values between date elements.
                                    ubnew = UBound(arrfil) * 2 + 1
                                    ReDim arrfil2(0 To ubnew)
                                    For j = 0 To ubnew Step 2
                                        arrfil2(j) = 2
                                        'prevention in national date format
                                        arrfil2(j + 1) = Month(arrfil(j / 2)) & "/" & Day(arrfil(j / 2)) & "/" & Year(arrfil(j / 2))
                                    Next j
                                End With
                                OneFilter.Add arrfil2, "critdate" 'critdate is key for date format
                            Else
 
                            End If
                        Else
                            'filter with more then 2 values from list (integer, text etc.)
                            On Error GoTo errline
                            ReDim arrfil(toplim - 1)
                            j = 0
                            For Each cri In .Criteria1
                                arrfil(j) = cri
                                j = j + 1
                            Next
                            OneFilter.Add arrfil, "crit"
                        End If
                        On Error GoTo errline
                    End If
                End If
            End With
 
'            For Each se In OneFilter
'                If VarType(se) = 8204 Or VarType(se) = 8200 Then
'                    For Each see In se
'                       Debug.Print see
'                    Next
'                Else
'                    Debug.Print se
'                End If
'            Next
            Set allFilters(i) = OneFilter
            Set OneFilter = Nothing
        Next
        getAutofilterPar = allFilters
    Else
        Erase allFilters
        getAutofilterPar = allFilters
    End If
End With
Exit Function
errline:
'your error function here
End Function
Public Function setAutofilterPar(tabname As String, RanFill As Range, allFilters As Variant) As Boolean
'#############################################################
'Sets autofilter params in table tabname for range RanFill
'allFilters is an array of collections, members of collection are "operator", "onoff" and "crit" or "critdate"
'
'#############################################################
Dim onef As New Collection
Dim filcount As Integer, i As Integer
Const MySingleSelection As Variant = Empty
On Error GoTo errline
filcount = UBound(allFilters)
With Sheets(tabname)
    If .AutoFilterMode Then
        For i = 1 To filcount
            Set onef = allFilters(i)
            If onef("onoff") Then
                Select Case onef("operator")
                    Case xlOr
                        RanFill.AutoFilter Field:=i, Criteria1:=onef("crit")(0), Operator:=xlOr, Criteria2:=onef("crit")(1)
                    Case MySingleSelection
                        If UCase(CStr(Mid(onef("crit")(0), 2)) = "PRAVDA") Then 'for czech Excel only
                            RanFill.AutoFilter Field:=i, Criteria1:=True
                        ElseIf UCase(CStr(Mid(onef("crit")(0), 2)) = "NEPRAVDA") Then 'for czech Excel only
                            RanFill.AutoFilter Field:=i, Criteria1:=False
                        Else
                            'criteria without "="
                            RanFill.AutoFilter Field:=i, Criteria1:=CStr(Mid(onef("crit")(0), 2))
                        End If
                    Case xlFilterValues
                        On Error Resume Next
                        If IsDate(onef("crit")(0)) And False Then 'if "crit" is not a key, then key "critdate" exists - for array of date
                            On Error GoTo errline
                            'Criteria are dates
                            RanFill.AutoFilter Field:=i, Criteria2:=onef("critdate"), Operator:=xlFilterValues
                        Else
                            On Error GoTo errline
                            'Criteria aren't dates
                            RanFill.AutoFilter Field:=i, Criteria1:=onef("crit"), Operator:=xlFilterValues
                        End If
                End Select
 
            End If
        Next
    End If
End With
Set onef = Nothing
setAutofilterPar = True
Exit Function
errline:
'your error function here
End Function
Public Function GetIndex(ByRef iaList, ByVal whatfind As Variant) As Long
'if value is not in an array then return -1, else return index of value
Dim i As Integer
Dim first As Integer, lim As Integer
'whatfind = CStr(whatfind)
GetIndex = -1
On Error Resume Next
If (UBound(iaList) And False) Then Exit Function
On Error GoTo 0
lim = UBound(iaList)
first = LBound(iaList)
 For i = first To lim
  If whatfind = iaList(i) Then
   GetIndex = i
   Exit For
  End If
 Next i
End Function
Sub example()
Dim we As Variant
    we = getAutofilterPar("List1")
    Sheets("List1").AutoFilterMode = False
    Sheets("List1").Range("B2:E19").AutoFilter
    setAutofilterPar "List1", Sheets("List1").Range("B2:E19"), we
End Sub
 
 

VBA autofilter