Office: Auto-Filter mit Wert der aktiven Zelle

Struppix · 26. August 2010

Hm..., ich hab's jetzt gerade mal da reingeschrieben, wo ich beschrieben habe.
Jetzt habe ich bei den Makros aber nur noch die zwei Funktionen "Tabelle1.EreignisseEin" und "Tabelle1.EreignisseAus". Bei beiden Funktionen tut sich bei "Ausführen" gar nix...
Ich blick's jetzt gar nimmer... :-(

Severus · 26. August 2010

Du kannst das ganze auch so verwenden:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Zelle As Range
Dim LZeile As Long
'Optional, wenn Du die Aktualisierung des Filters nur willst, wenn die Daten einer bestimmten Spalte geändert werden:
'If Target.Column 5 then Exit Sub 'Nur wenn Spalte 5 geändert wird
'If Target.Column < 3 or Target.Column > 7 Then Exit Sub 'Nur wenn die Spalten 3 bis 7 geändert werden
'If Target.Column > 3 Or Target.Column < 7 Then Exit Sub 'Nicht wenn Spalten 4 - 7 geändert werden
'Das verhindert ständiges unerwünschtes Aktualisieren.
With Application
.EnableEvents = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With ActiveSheet
LZeile = .Cells.Find("*", .Range("A1"), , , xlByRows, xlPrevious).Row
If Right(ActiveCell.NumberFormat, 1) = "%" Then
ActiveCell = Format(ActiveCell, "0.00%")
ElseIf Right(ActiveCell.NumberFormat, 1) = "]" Then
For Each Zelle In .Range(.Cells(2, ActiveCell.Column), .Cells(LZeile, ActiveCell.Column))
Zelle = Format(Zelle, "#,##0.00 [$€-1]")
Next
End If
' .Range("A1:V1").AutoFilter
.Range("A1:V" & LZeile).AutoFilter _
Field:=ActiveCell.Column, Criteria1:=ActiveCell.Value
.Columns(ActiveCell.Column).TextToColumns
End With
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
'Löscht den Filter, wenn man das Tabellenblatt "rechtsklickt".
If FilterMode Then ShowAllData
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Das ganze im CodeModul der Tabelle, die gefiltert werden soll
z.B. "Tabelle1 (Bestellungen)" sollte es tun.
Viel Spaß

Das mit dem "passiert gar nix" liegt daran, daß hier nur das Abfangen von Ereignissen während des Progarmmablaufs ab- bzw. wieder eingeschaltet wird.
Severus *wink.gif*

Backowe · 26. August 2010

Hi Stefan,

Bei den beiden Makros "EreignisseEin" und "EreignisseAus" kannst Du auch nicht sehen was passiert, ich habe die Funktionalitäten mal dokumentiert. Die beiden Makros sind der Übersicht halber ausgelagert.

Jetzt noch ein heißer Insidertipp, wenn Du einen Begriff nicht verstehen kannst, einfach den Cursor in den Begriff stellen und F1 drücken,die Hilfe ist eigentlich nicht schlecht, da wird alles erklärt! *wink.gif*

[Edit]: Was mir nachträglich noch aufgefallen ist, daß nicht nach Datum gefiltert werden kann, ist jetzt auch eingebaut. der ganze Makrocode steht jetzt in einem Modul, über Alt-F8, Optionen kannst Du für den beiden Makros die Tastenkombinationen vergeben die ich im Makro dokumentiert habe.

Hoffe es passt jetzt so! *Smilie

Code:

' **************************************************************
' Modul: Modul1 Typ = Allgemeines Modul
' **************************************************************

Public Function AF_KRIT(Bereich As Range) As String
'Liest die Kriterien des Autofilters aus und listet diese in einer Zelle
'Als Bezug wird die erste Zelle nach dem Spaltentitel angegeben:
'AF_KRIT(A2)
'von Thomas Ramel

Dim s_Filter As String

s_Filter = ""
On Error GoTo Ende
With Bereich.Parent.AutoFilter
With .Filters(Bereich.Column - .Range.Column + 1)
s_Filter = .Criteria1
Select Case .Operator
Case xlAnd
s_Filter = s_Filter & " UND " & .Criteria2
Case xlOr
s_Filter = s_Filter & " ODER " & .Criteria2
End Select
End With
End With
Ende:
AF_KRIT = s_Filter
End Function

Sub NachZelleFiltern()
'Shortcut: Strg + Shift + F
Dim Zelle As Range
Dim LZeile As Long
EreignisseAus
With ActiveSheet
LZeile = .Cells.Find("*", .Range("A1"), , , xlByRows, xlPrevious).Row
If Right(ActiveCell.NumberFormat, 1) = "%" Then
ActiveCell = Format(ActiveCell, "0.00%")
ElseIf Right(ActiveCell.NumberFormat, 1) = "]" Then
For Each Zelle In .Range(.Cells(2, ActiveCell.Column), .Cells(LZeile, ActiveCell.Column))
Zelle = Format(Zelle, "#,##0.00 [$€-1]")
Next
ElseIf IsDate(ActiveCell) Then
For Each Zelle In .Range(.Cells(2, ActiveCell.Column), .Cells(LZeile, ActiveCell.Column))
Zelle = CStr(Zelle)
Next
End If
.Range("A1:V1").AutoFilter
.Range("A1:V" & LZeile).AutoFilter _
Field:=ActiveCell.Column, Criteria1:=ActiveCell.Value
If IsDate(ActiveCell) Then
For Each Zelle In .Range(.Cells(2, ActiveCell.Column), .Cells(LZeile, ActiveCell.Column))
Zelle = CDate(Zelle)
Next
End If
.Columns(ActiveCell.Column).TextToColumns
End With
EreignisseEin
End Sub

Sub AlleDatensaetzeAnzeigen()
'Shortcut: Strg + Shift + A
If ActiveSheet.FilterMode Then _
ActiveSheet.ShowAllData
End Sub

Sub EreignisseAus()
With Application
.EnableEvents = False 'Ereignisverarbeitung ausschalten
.Calculation = xlCalculationManual 'Automatische Berechnung ausschalten
.ScreenUpdating = False 'Bildschirmaktualisierung ausschalten
End With
End Sub

Sub EreignisseEin()
With Application
.Calculation = xlCalculationAutomatic 'Automatische Berechnung einschalten
.ScreenUpdating = True 'Bildschirmaktualisierung einschalten
.EnableEvents = True 'Ereignisverarbeitung einschalten
End With
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Code eingefügt mit:
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Office: Auto-Filter mit Wert der aktiven Zelle

Auto-Filter mit Wert der aktiven Zelle

Auto-Filter mit Wert der aktiven Zelle

Auto-Filter mit Wert der aktiven Zelle - Similar Threads - Auto Filter Wert

Auto-Ausfüllen auch über mehrere Tabellen?

Schnellbausteine, Auto Text und Auswahlfeld in Vorlage

Namensliste Auto-Einstellungen

Wenn in Zelle A1 "Auto" dann in Zelle A2 "Fahren", wenn in Zelle A1 "zu Fuß" dann in Zelle A2 "Gehen

VBA Active X steuerelemente Auto-Eingabe wen eine Eingabe erfolgt

Anruf Verlauf - für erstellte Auto attendants/ Call queues

Auto Filter nur auf bestimmte Spalten (Excel 97)