VBA Excel AutoFilter сделать настройки постоянными - PullRequest
Новая
       22

VBA Excel AutoFilter сделать настройки постоянными

0 голосов
/ 19 октября 2018

Я пытался реализовать AdvancedAutoFilter с VBA.Это работает просто отлично.Но, к сожалению, при изменении чего-либо в файле, автофильтр отменяется.Я исправил это с помощью ActiveSheet.ListObjects(1).Range.AutoFilter

Но теперь, каждый раз, когда я фильтрую и изменяю что-то на листе, выбранные фильтры становятся забытыми, что довольно раздражает.Есть ли способ обойти это поведение?

С уважением 

Private Sub Worksheet_Change(ByVal Target As Range)
    ' Filters LagerlisteHW Row B for the word "Selfservice" and copys the corresponding lines
    ' to the sheet "Selfservice" to rows with the headers deefined in Selfservice!A2:C2
    ' Define the search-criteria in Selfservice!L1:L2 (currently the word "Selfservice")


    Sheets("LagerlisteHW").Range("B5").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=Sheets("Selfservice").Range("L1:L2"), CopyToRange:=Sheets("Selfservice").Range("A2:C2"), Unique:=False


    If ActiveSheet.AutoFilterMode = False Then
        ActiveSheet.ListObjects(1).Range.AutoFilter
    End If



    'Selection.AutoFilter    ' Enable the AutoFilter Mode


End Sub

1 Ответ

0 голосов
/ 19 октября 2018

Вы должны сохранить автофильтр и повторно применить его после запуска расширенного фильтра.Я использовал код из здесь и разделил его на две подпрограммы.Код будет выглядеть так 

Private Sub Worksheet_Change(ByVal Target As Range)
' Filters LagerlisteHW Row B for the word "Selfservice" and copys the corresponding lines
' to the sheet "Selfservice" to rows with the headers deefined in Selfservice!A2:C2
' Define the search-criteria in Selfservice!L1:L2 (currently the word "Selfservice")

Dim wks As Worksheet
Dim filterArray As Variant
Dim curFiltRange As String

    Set wks = Sheets("LagerlisteHW")
    StoreAutoFilter wks, filterArray, curFiltRange

    Sheets("LagerlisteHW").Range("B5").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
                                                                    CriteriaRange:=Sheets("Selfservice").Range("L1:L2"), CopyToRange:=Sheets("Selfservice").Range("A2:C2"), Unique:=False


    If ActiveSheet.AutoFilterMode = False Then
        ActiveSheet.ListObjects(1).Range.AutoFilter
    End If

    RedoAutoFilter wks, filterArray, curFiltRange

    'Selection.AutoFilter    ' Enable the AutoFilter Mode

End Sub

Sub StoreAutoFilter(ByVal wks As Worksheet, ByRef filterArray As Variant, ByRef currentFiltRange As String)

    Dim col As Integer
    Dim f As Long

    ' Capture AutoFilter settings
    With wks.AutoFilter
        currentFiltRange = .Range.Address
        With .Filters
            ReDim filterArray(1 To .Count, 1 To 3)
            For f = 1 To .Count
                With .Item(f)
                    If .On Then
                        filterArray(f, 1) = .Criteria1
                        If .Operator Then
                            filterArray(f, 2) = .Operator
                            filterArray(f, 3) = .Criteria2 'simply delete this line to make it work in Excel 2010
                        End If
                    End If
                End With
            Next f
        End With
    End With

End Sub

Sub RedoAutoFilter(ByVal wks As Worksheet, ByVal filterArray As Variant, ByRef currentFiltRange As String)
Dim i As Long
Dim col As Integer

    ' Restore Filter settings
    For col = 1 To UBound(filterArray, 1)
        If Not IsEmpty(filterArray(col, 1)) Then
            If filterArray(col, 2) Then
                wks.Range(currentFiltRange).AutoFilter field:=col, _
                Criteria1:=filterArray(col, 1), _
                Operator:=filterArray(col, 2), _
                Criteria2:=filterArray(col, 3)
            Else
                wks.Range(currentFiltRange).AutoFilter field:=col, _
                Criteria1:=filterArray(col, 1)
            End If
        End If
    Next col

End Sub
...