Excel VBA – uložení a obnovení automatického filtru

14. 10. 2023 / Excel, VBA / 6 minut čtení / Diskuze

Pro uložení a obnovení automatického filtru na listu v Excelu pomocí VBA (Visual Basic for Applications), můžete použít následující kód. Tento kód uloží aktuální stav filtru do proměnné a poté ho obnoví, když je to potřeba.

Sub UlozitFiltr()
    Dim AktualniFiltr As Filter
    Dim List As Worksheet
    
    ' Nastavte list, na kterém chcete uložit filtr
    Set List = ThisWorkbook.Sheets("List1") ' Změňte na název vašeho listu
    
    ' Uložit aktuální filtr
    Set AktualniFiltr = List.AutoFilter
End Sub

Sub ObnovitFiltr()
    Dim List As Worksheet
    Dim AktualniFiltr As Filter
    
    ' Nastavte list, na kterém chcete obnovit filtr
    Set List = ThisWorkbook.Sheets("List1") ' Změňte na název vašeho listu
    
    ' Zkontrolujte, zda byl filtr uložen
    If Not List.AutoFilter Is Nothing Then
        ' Obnovit filtr
        Set AktualniFiltr = List.AutoFilter
    Else
        MsgBox "Není uložený filtr k obnovení."
    End If
End Sub

Tento kód obsahuje dvě procedury:

  1. UlozitFiltr: Tato procedura uloží aktuální stav filtru na listu. Pro použití této procedury přepněte na list, na kterém chcete uložit filtr, a spusťte ji.
  2. ObnovitFiltr: Tato procedura obnoví uložený filtr na listu. Opět musíte být na listu, kde chcete obnovit filtr, a spustit tuto proceduru. Pokud není uložený filtr, zobrazí se vám zpráva.

Ujistěte se, že jste nastavili proměnnou List na váš konkrétní list, na kterém chcete pracovat.

Pokud chcete ukládat a obnovovat nastavení filtrovaných položek (které sloupce byly filtrovány a jaká kritéria byla použita), můžete využít následujícího kódu. Tento kód uloží filtr do proměnné ve formě pole a později ho obnoví:

Sub UlozitFiltr()
    Dim AktualniFiltr As Filter
    Dim List As Worksheet
    Dim FiltrPole() As Variant
    Dim i As Long

    ' Nastavte list, na kterém chcete uložit filtr
    Set List = ThisWorkbook.Sheets("List1") ' Změňte na název vašeho listu
    
    ' Uložit aktuální filtr do pole
    Set AktualniFiltr = List.AutoFilter
    If Not AktualniFiltr Is Nothing Then
        ReDim FiltrPole(1 To AktualniFiltr.Filters.Count, 1 To 3)
        i = 1
        For Each F In AktualniFiltr.Filters
            FiltrPole(i, 1) = F.ColumnIndex
            FiltrPole(i, 2) = F.On
            FiltrPole(i, 3) = F.Criteria1
            i = i + 1
        Next F
    End If

    ' Uložit filtr do proměnné
    List.Cells(1, 1).Value = Join(Application.Transpose(FiltrPole), "|")
End Sub

Sub ObnovitFiltr()
    Dim List As Worksheet
    Dim FiltrPole() As String
    Dim i As Long
    Dim AktualniFiltr As Filter
    Dim ColumnIndex As Long
    Dim OnOff As Boolean
    Dim Criteria As String

    ' Nastavte list, na kterém chcete obnovit filtr
    Set List = ThisWorkbook.Sheets("List1") ' Změňte na název vašeho listu
    
    ' Získejte uložený filtr z buňky A1
    FiltrPole = Split(List.Cells(1, 1).Value, "|")

    ' Zkontrolujte, zda byl filtr uložen
    If UBound(FiltrPole) > 0 Then
        ' Obnovit filtr
        Set AktualniFiltr = List.AutoFilter
        If Not AktualniFiltr Is Nothing Then
            ' Deaktivovat aktuální filtr
            AktualniFiltr.ShowAllData
        End If

        ' Nastavit filtry podle uložených hodnot
        For i = LBound(FiltrPole) To UBound(FiltrPole)
            ColumnIndex = CLng(Split(FiltrPole(i), "|")(0))
            OnOff = CBool(Split(FiltrPole(i), "|")(1))
            Criteria = Split(FiltrPole(i), "|")(2)
            List.Cells(1, ColumnIndex).AutoFilter Field:=ColumnIndex, Criteria1:=Criteria, Operator:=xlFilterValues
        Next i
    Else
        MsgBox "Není uložený filtr k obnovení."
    End If
End Sub

Tento kód použije buňku A1 na listu pro uložení filtru ve formě textového řetězce a poté ho obnoví na základě těchto uložených hodnot. Ujistěte se, že jste nastavili proměnnou List na váš konkrétní list, na kterém chcete pracovat.

Pokud chcete ukládat a obnovovat nastavení filtrovaných položek pro všechny sloupce, kde je použito filtrování, můžete použít následující kód. Tento kód projde všechny sloupce a uloží a obnoví nastavení filtru pro každý sloupec:

Sub UlozitFiltr()
    Dim AktualniFiltr As Filter
    Dim List As Worksheet
    Dim FiltrPole() As Variant
    Dim ColumnIndex As Long
    Dim i As Long
    
    ' Nastavte list, na kterém chcete ukládat filtry
    Set List = ThisWorkbook.Sheets("List1") ' Změňte na název vašeho listu
    
    ' Uložit aktuální filtr pro všechny sloupce
    ReDim FiltrPole(1 To List.Cells(1, List.Columns.Count).End(xlToLeft).Column, 1 To 3)
    For ColumnIndex = 1 To UBound(FiltrPole, 1)
        Set AktualniFiltr = List.AutoFilter
        If Not AktualniFiltr Is Nothing Then
            If AktualniFiltr.Filters(ColumnIndex).On Then
                FiltrPole(ColumnIndex, 1) = ColumnIndex
                FiltrPole(ColumnIndex, 2) = AktualniFiltr.Filters(ColumnIndex).On
                FiltrPole(ColumnIndex, 3) = AktualniFiltr.Filters(ColumnIndex).Criteria1
            End If
        End If
    Next ColumnIndex

    ' Uložit filtry do proměnné
    List.Cells(1, 1).Value = Join(Application.Transpose(FiltrPole), "|")
End Sub

Sub ObnovitFiltr()
    Dim List As Worksheet
    Dim FiltrPole() As String
    Dim ColumnIndex As Long
    Dim OnOff As Boolean
    Dim Criteria As String
    Dim AktualniFiltr As Filter
    
    ' Nastavte list, na kterém chcete obnovit filtry
    Set List = ThisWorkbook.Sheets("List1") ' Změňte na název vašeho listu
    
    ' Získejte uložené filtry z buňky A1
    FiltrPole = Split(List.Cells(1, 1).Value, "|")

    ' Zkontrolujte, zda byly filtry uloženy
    If UBound(FiltrPole) > 0 Then
        ' Obnovit filtry pro všechny sloupce
        For Each FilterInfo In FiltrPole
            ColumnIndex = CLng(Split(FilterInfo, "|")(0))
            OnOff = CBool(Split(FilterInfo, "|")(1))
            Criteria = Split(FilterInfo, "|")(2)
            List.Cells(1, ColumnIndex).AutoFilter Field:=ColumnIndex, Criteria1:=Criteria, Operator:=xlFilterValues
        Next FilterInfo
    Else
        MsgBox "Nebyly uloženy žádné filtry k obnovení."
    End If
End Sub

Tento kód projde všechny sloupce na listu a uloží nebo obnoví filtry pro všechny sloupce, kde bylo filtrování aktivováno. Ujistěte se, že jste nastavili proměnnou List na váš konkrétní list, na kterém chcete pracovat.

Pokud chcete, aby kód fungoval na aktuálním listu, na kterém se nacházíte, můžete použít následující upravený kód. Tento kód bude používat aktivní list (ten, na kterém se právě nacházíte) pro uložení a obnovení filtrů ve všech sloupcích.

Sub UlozitFiltr()
    Dim AktualniFiltr As Filter
    Dim List As Worksheet
    Dim FiltrPole() As Variant
    Dim ColumnIndex As Long
    Dim i As Long
    
    ' Nastavte aktivní list, na kterém chcete ukládat filtry
    Set List = ActiveSheet
    
    ' Uložit aktuální filtr pro všechny sloupce
    ReDim FiltrPole(1 To List.Cells(1, List.Columns.Count).End(xlToLeft).Column, 1 To 3)
    For ColumnIndex = 1 To UBound(FiltrPole, 1)
        Set AktualniFiltr = List.AutoFilter
        If Not AktualniFiltr Is Nothing Then
            If AktualniFiltr.Filters(ColumnIndex).On Then
                FiltrPole(ColumnIndex, 1) = ColumnIndex
                FiltrPole(ColumnIndex, 2) = AktualniFiltr.Filters(ColumnIndex).On
                FiltrPole(ColumnIndex, 3) = AktualniFiltr.Filters(ColumnIndex).Criteria1
            End If
        End If
    Next ColumnIndex

    ' Uložit filtry do buňky A1 aktivního listu
    List.Cells(1, 1).Value = Join(Application.Transpose(FiltrPole), "|")
End Sub

Sub ObnovitFiltr()
    Dim List As Worksheet
    Dim FiltrPole() As String
    Dim ColumnIndex As Long
    Dim OnOff As Boolean
    Dim Criteria As String
    Dim AktualniFiltr As Filter
    
    ' Nastavte aktivní list, na kterém chcete obnovit filtry
    Set List = ActiveSheet
    
    ' Získejte uložené filtry z buňky A1 aktivního listu
    FiltrPole = Split(List.Cells(1, 1).Value, "|")

    ' Zkontrolujte, zda byly filtry uloženy
    If UBound(FiltrPole) > 0 Then
        ' Obnovit filtry pro všechny sloupce
        For Each FilterInfo In FiltrPole
            ColumnIndex = CLng(Split(FilterInfo, "|")(0))
            OnOff = CBool(Split(FilterInfo, "|")(1))
            Criteria = Split(FilterInfo, "|")(2)
            List.Cells(1, ColumnIndex).AutoFilter Field:=ColumnIndex, Criteria1:=Criteria, Operator:=xlFilterValues
        Next FilterInfo
    Else
        MsgBox "Nebyly uloženy žádné filtry k obnovení."
    End If
End Sub

Tento kód používá aktivní list pro uložení a obnovení filtrů ve všech sloupcích. Přepněte se na list, na kterém chcete provádět operace, a spusťte příslušnou proceduru.

Příklad řešení v rámci jedné procedury:

Private Sub cbSplit_Click()
    Dim ws As Worksheet
    Dim filterArray()
    Dim currentFiltRange As String
    Dim col As Integer

    Application.ScreenUpdating = False
    Set ws = ActiveSheet
    'Capture AutoFilter settings
    If ws.AutoFilterMode = True Then
        With ws.AutoFilter
            currentFiltRange = .Range.Address
            With .Filters
                ReDim filterArray(1 To .Count, 1 To 3)
                For col = 1 To .Count
                    With .Item(col)
                        If .On Then
                            filterArray(col, 1) = .Criteria1
                            If .Operator Then
                                filterArray(col, 2) = .Operator
                                If .Operator = xlAnd Or .Operator = xlOr Then
                                    filterArray(col, 3) = .Criteria2
                                End If
                            End If
                        End If
                    End With
                Next col
            End With
        End With
    End If

    'Remove AutoFilter
    ws.AutoFilterMode = False

    'jiný kód sem

    'Restore Filter settings
    If Not currentFiltRange = "" Then
        ws.Range(currentFiltRange).AutoFilter
        For col = 1 To UBound(filterArray(), 1)
            If Not IsEmpty(filterArray(col, 1)) Then
                If filterArray(col, 2) Then
                    'check if Criteria2 exists and needs to be populated
                    If filterArray(col, 2) = xlAnd Or filterArray(col, 2) = xlOr Then
                        ws.Range(currentFiltRange).AutoFilter Field:=col, _
                            Criteria1:=filterArray(col, 1), _
                            Operator:=filterArray(col, 2), _
                            Criteria2:=filterArray(col, 3)
                    Else
                        ws.Range(currentFiltRange).AutoFilter Field:=col, _
                            Criteria1:=filterArray(col, 1), _
                            Operator:=filterArray(col, 2)
                    End If
                Else
                    ws.Range(currentFiltRange).AutoFilter Field:=col, _
                        Criteria1:=filterArray(col, 1)
                End If
            End If
        Next col
    End If
    Application.ScreenUpdating = True
End Sub

Zdrojem toho příkladu je diskuse na adrese https://www.mrexcel.com/board/threads/capture-autofilter-state.333961/

Související příspěvky

Diskuze

Vaše e-mailová adresa nebude zveřejněna. Vyžadované informace jsou označeny *

Přejít nahoru