Tabelle - Autofilter auf Datum prüfen

[LuckyJoe]

Hallo zusammen,

ich suche eine Möglichkeit, innerhalb einer Tabelle bei einem gesetzten Filter zu prüfen, ob in der Spalte nach Datum gefiltert ist. Nachfolgenden Code habe ich schon, aber bei Datumsfiltern bleibt das Filterkriterium "Crit1" immer leer. Wie muss der Code aussehen, um festzustellen, dass entweder nach einem Datum gefiltert wurde oder nach mehreren (Array?)? Die entscheidende Stelle ist nach dem Kommentar " ### Hier prüfen, ob nach Datum gefiltert ist ###":

Code:

Option Explicit

Sub FilterDerAktivenSpaltePruefen()
   
    Dim MyLO As ListObject
    Dim AF As AutoFilter
    Dim Spalte As Long
    Dim WSh As Worksheet
    Dim Crit1 As Variant, Crit2 As Variant
    Dim Op As XlAutoFilterOperator
    Dim i As Long
    Dim Result As String

    Set WSh = ThisWorkbook.Sheets("Test")
    Set MyLO = WSh.ListObjects("MyTab")
   
    ' Prüfen, ob ActiveCell innerhalb der Tabelle liegt
    If Intersect(ActiveCell, MyLO.DataBodyRange) Is Nothing Then
        MsgBox "Die aktive Zelle liegt nicht innerhalb der Tabelle."
        Exit Sub
    End If

    ' Autofilter prüfen
    If Not MyLO.ShowAutoFilter Then
        MsgBox "Die Tabelle hat keinen Autofilter aktiviert."
        Exit Sub
    End If

    ' Sicherstellen, dass AutoFilter-Objekt existiert
    On Error Resume Next
    Set AF = MyLO.Range.Worksheet.AutoFilter
    On Error GoTo 0

    If AF Is Nothing Then
        MsgBox "Noch nie ein Filter gesetzt – kein AutoFilter-Objekt vorhanden."
        Exit Sub
    End If

    ' Spalte innerhalb der Tabelle ermitteln
    Spalte = ActiveCell.Column - MyLO.Range.Cells(1, 1).Column + 1

    ' Prüfen, ob in dieser Spalte ein Filter aktiv ist
    If Spalte > AF.Filters.Count Then
        MsgBox "Spalte liegt außerhalb der gefilterten Spalten."
        Exit Sub
    End If

    If AF.Filters(Spalte).On Then
   
        ' Abfangen bei speziellen Typen wie Datum
        ' ### Hier prüfen, ob nach Datum gefiltert ist ###
        On Error Resume Next
        Crit1 = AF.Filters(Spalte).Criteria1
        Op = AF.Filters(Spalte).Operator
        Crit2 = AF.Filters(Spalte).Criteria2
        On Error GoTo 0
   
        ' Auswertung
        If IsArray(Crit1) Then
            Result = "Mehrere Kriterien: "
            For i = LBound(Crit1) To UBound(Crit1)
                Result = Result & vbNewLine & "- " & Format(Crit1(i), "dd.mm.yy")
            Next i
            MsgBox Result
        ElseIf Not IsMissing(Crit2) And Not IsEmpty(Crit2) Then
            MsgBox "Kriterien: " & FormatKriterium(Crit1) & " " & IIf(Op = xlOr, "ODER", "UND") & " " & FormatKriterium(Crit2)
        Else
            MsgBox "Aktives Filterkriterium: " & FormatKriterium(Crit1)
        End If
    Else
        MsgBox "In der aktiven Spalte ist kein Filter aktiv."
    End If

End Sub

Private Function FormatKriterium(val As Variant) As String

    If IsDate(val) Then
        FormatKriterium = Format(val, "dd.mm.yy")
    Else
        FormatKriterium = CStr(val)
    End If

End Function

Anbei die Datei einmal als .xlsm, einmal als .xlsx.

  IT.xlsm (Größe: 29 KB / Downloads: 6)
  IT.xlsx (Größe: 15,69 KB / Downloads: 5)

Danke für's Lesen.

[{Boris}]

Hi,

Code:

Sub Filterspalte_4()
Dim B As Boolean
B = ActiveSheet.ListObjects("MyTab").AutoFilter.Filters(4).On
MsgBox "Datumsspalte ist gefiltert: " & B
End Sub

[LuckyJoe]

Hi,

danke, die Prüfung habe ich schon; mir geht es um die Kriterien: was beinhalten die bei einem Datumsfilter?

[Egon12]

Hallo Jörg,

über das Objekt kommst du so nicht an den Filterkriterien nach der Ausführung des Filters dran.

Um an die gemachten Filtereinstellungen ran zu kommen musst du eine Kopie dieser Datei anlegen --> Zippen --> die XML Datei "table1.xml" auslesen.

In deinem Beispiel stellt sich der XML Teil so dar:

Code:

<table xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" xmlns:xr="http://schemas.microsoft.com/office/spreadsheetml/2014/revision" xmlns:xr3="http://schemas.microsoft.com/office/spreadsheetml/2016/revision3" mc:Ignorable="xr xr3" id="1" xr:uid="{9BCE2C94-1936-421F-9558-39256FD9235E}" name="MyTab" displayName="MyTab" ref="B3:F24" totalsRowCount="1" headerRowDxfId="6" totalsRowDxfId="5">
<autoFilter ref="B3:F23" xr:uid="{9BCE2C94-1936-421F-9558-39256FD9235E}">
<filterColumn colId="3">
<filters>
<dateGroupItem year="2025" month="2" day="8" dateTimeGrouping="day"/>
<dateGroupItem year="2025" month="3" day="3" dateTimeGrouping="day"/>
</filters>
</filterColumn>
</autoFilter>
<tableColumns count="5">
<tableColumn id="1" xr3:uid="{485BFF7B-947A-468C-A1BB-3B0F085F46C1}" name="Nr" totalsRowFunction="count" totalsRowDxfId="4"/>
<tableColumn id="2" xr3:uid="{CD73E03D-E3E7-4A75-AECA-6B6C7A9601A6}" name="Name" totalsRowDxfId="3"/>
<tableColumn id="3" xr3:uid="{A7B5A686-0E2F-4D46-9860-9A2874780B80}" name="Vorname" totalsRowDxfId="2"/>
<tableColumn id="4" xr3:uid="{4369E98E-ADB4-4659-8825-3C94096765CA}" name="Zahltag" totalsRowDxfId="1"/>
<tableColumn id="5" xr3:uid="{A0A1EFD6-22AF-47AC-BD9A-305E9751005B}" name="Betrag" totalsRowFunction="sum" totalsRowDxfId="0"/>
</tableColumns>
<tableStyleInfo name="TableStyleMedium2" showFirstColumn="0" showLastColumn="0" showRowStripes="1" showColumnStripes="0"/>
</table>

relevant ist dieser Teil:

Code:

<filters>
<dateGroupItem year="2025" month="2" day="8" dateTimeGrouping="day"/>
<dateGroupItem year="2025" month="3" day="3" dateTimeGrouping="day"/>
</filters>

Man kann dies automatisieren, aber das ist doch ein sperriger Weg.

Gruß Uwe

[LuckyJoe]

Hallo Uwe,

danke für deine verständliche untd interessante Eklärung; so wie ich das sehe, hat MS also einfach eine Methode dafür vergessen – kann ja mal vorkommen

Ok, dann prüfe ich erst einmal nicht auf Kriterien bei Datumsfiltern.

[Egon12]

Hallo Jörg,
 
ich setzte mich mal hin und stelle eine Lösung zusammen, wo der komplette Filterstatus brauchbar ausgegeben werden kann. 
Heute und morgen fehlt mir ein bisschen die Zeit dafür. Schau einfach hin und wieder mal rein, ob ich da schon was hinterlassen habe.
 
Gruß Uwe

[Egon12]

Hallo Jörg,
 
ich habe mir noch ein paar Sachen aus der MS Hilfe anlesen müssen um an den Xml Kram ran zu kommen.
Das Ganze ist natürlich ohne jede Fehlerbehandlung. Es wird nur zum Anfang geprüft, ob der Autofilter gesetzt ist oder nicht.
 
Um das Ganze steuerbar zu halten, falls du unterschiedliche Auswertungen nutzen möchtest ist dies entsprechend parametrisiert aufzurufen.

Code:

Option Explicit
    Private strXml$
Sub AbfrageAF()
    ' Die Nummerierung der Xml Datei für die Tabellenstruktur enspricht der Modulnummer des jeweiligen Tabellenblattes
    Call XmlTabelleAuslesen(Listobjekt:=Tabelle1.ListObjects(1), XmlName:="table1.xml", Ausgabe:="AusgabeFilterwerte")
End Sub
Private Sub AusgabeFilterwerte()
    Dim Start&, Ende&
    ' hier kannst du den XML String dir nach deinen Vorstellungen anpassen/verarbeiten/ausgeben
    Start = InStr(1, strXml, "<filters")
    Ende = InStrRev(strXml, "</filterColumn")
    strXml = Mid(strXml, Start, Ende - Start)
    MsgBox Replace(strXml, " ", vbCrLf)
End Sub
Sub XmlTabelleAuslesen(ByVal Listobjekt As ListObject, ByVal XmlName As String, Ausgabe)
    Dim booAFilter As Boolean: booAFilter = Listobjekt.AutoFilter.FilterMode
    Dim fStatus$, Pfad_TmpExcel As Variant, zipXml, tmpFolder
    Dim objShell As Object, objZipFile As Object, objZiel As Object, objZip As Object
   
    If booAFilter = False Then MsgBox "Es ist kein Filter gesetzt", vbInformation, "Filterstatus": Exit Sub
    tmpFolder = Environ("temp")
    Pfad_TmpExcel = tmpFolder & "\" & "tmpExcel" & ".zip"
    zipXml = "xl\tables\" & XmlName
    Application.ScreenUpdating = False
    ThisWorkbook.Sheets(Array(Listobjekt.Range.Worksheet.Name)).Copy
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Pfad_TmpExcel, xlOpenXMLWorkbook
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
    Set objShell = CreateObject("Shell.Application")
    Set objZip = objShell.Namespace(Pfad_TmpExcel)
    Set objZipFile = objZip.Items.Item(zipXml)
    Set objZiel = objShell.Namespace(tmpFolder)
    objZiel.CopyHere objZipFile, 16 ' Best.Abfrage mit Ja
    Open tmpFolder & "\" & XmlName For Binary Access Read As 1
    strXml = Space(LOF(1))
    Get 1, 1, strXml
    Close 1
    Kill Pfad_TmpExcel
    Kill tmpFolder & "\" & XmlName
    Set objShell = Nothing
    Set objZipFile = Nothing
    Set objZiel = Nothing
    Run Ausgabe
End Sub

Gruß Uwe

[LuckyJoe]

... wow! Toll! Läuft ... und auch noch konfigrierbar. Danke!!!