Filtern....mit Anzeige des Filterkriteriums

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Wolfgang,
kopiere diesen Code in das Modul der entsprechenden Tabelle.
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_Calculate()
Dim objF As Filter
Dim strF As String
Dim intC As Integer
Dim objTB As Shape

If Me.AutoFilterMode Then
    For Each objF In Me.AutoFilter.Filters

        intC = intC + 1

        If objF.On Then

            strF = strF & Me.AutoFilter.Range(1, intC).Text & _
                String(14 - Len(Me.AutoFilter.Range(1, intC).Text), " ")

            strF = strF & "Kriterium1:= " & objF.Criteria1 & _
                String(14 - Len(objF.Criteria1), " ")

            If objF.Operator > 0 And objF.Operator < 3 Then strF = strF & _
                "Kriterium2:= " & objF.Criteria2 & String(14 - Len(objF.Criteria2), " ")

            strF = strF & "Verknüpfung:= "

            Select Case objF.Operator
                Case 1
                    strF = strF & "UND"
                Case 2
                    strF = strF & "ODER"
                Case 3
                    strF = strF & "Obersten 10 Elemente"
                Case 4
                    strF = strF & "Untersten 10 Elemente"
                Case 5
                    strF = strF & "Obersten 10 Prozent"
                Case 6
                    strF = strF & "Untersten 10 Prozent"
                Case Else
                    strF = strF & "Keine"
            End Select

            strF = strF & vbLf

        End If

    Next

    On Error Resume Next
    Set objTB = Me.Shapes("FilterText")
    On Error GoTo 0

    If objTB Is Nothing Then
        Set objTB = Me.Shapes.AddLabel(msoTextOrientationHorizontal, _
            Me.AutoFilter.Range.Left + Me.AutoFilter.Range.Width + 10, 10, 0#, 0#)

        With objTB
            .Name = "FilterText"
            .TextFrame.AutoSize = msoTrue
            .DrawingObject.Font.Name = "Fixedsys"
            .DrawingObject.Font.Underline = xlUnderlineStyleSingle
            .DrawingObject.Font.ColorIndex = 5
            .Fill.Visible = msoTrue
            .Fill.ForeColor.SchemeColor = 9
            .Line.Visible = msoTrue
            .Line.ForeColor.SchemeColor = 12
        End With

    End If

End If

If Not objTB Is Nothing Then
    objTB.TextFrame.Characters.Text = strF
    objTB.Visible = Len(strF) > 0
End If

End Sub

Zusätzlich muss in irgendeiner Zelle eine flüchtige Formel (z.B. "=JETZT()") stehen, damit das Calculate-Ereignis ausgelöst wird wenn sich der Filter ändert.

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Filtern....mit Anzeige des Filterkriteriums

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Filtern....mit Anzeige des Filterkriteriums

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread