|
Hallo! Wie versprochen hier die getestete Version. Habe es probiert und läuft auch mit Datum etc. Hatte es da vorher glaube ich zu kompliziert aufgezogen. VG
Option Explicit
Dim stelle As Long
Sub filter_zurück()
Dim liste()
Dim daten()
ReDim liste(0)
Dim i As Long
Dim j As Long
Dim eintrag As Boolean
Application.ScreenUpdating = False
With ActiveSheet.ListObjects("Auftragsliste")
daten = Range(.AutoFilter.Range.Address)
stelle = stelle - 1
'Zeile 1 ist Übeschrift
For i = 2 To .AutoFilter.Range.Rows.Count
eintrag = False
.Range.AutoFilter Field:=1
If UBound(Filter(liste, "x" & CStr(daten(i, 1)) & "x", , vbBinaryCompare)) = -1 Then
For j = 2 To .AutoFilter.Range.Columns.Count
If ActiveSheet.Rows(i + 1).Hidden = False Then eintrag = True
Next j
If eintrag = True Then
liste(0) = liste(0) + 1
ReDim Preserve liste(liste(0))
liste(liste(0)) = "x" & CStr(daten(i, 1)) & "x"
End If
End If
Next
If stelle = -1 Then stelle = UBound(liste)
If stelle = 0 Then
.Range.AutoFilter Field:=1
Exit Sub
End If
.Range.AutoFilter Field:=1, Criteria1:=Replace(Replace(liste(stelle), "x", ""), ",", ".")
End With
Application.ScreenUpdating = True
End Sub
Sub filter_vor()
Dim liste()
Dim daten()
ReDim liste(0)
Dim i As Long
Dim j As Long
Dim eintrag As Boolean
Application.ScreenUpdating = False
With ActiveSheet.ListObjects("Auftragsliste")
daten = Range(.AutoFilter.Range.Address)
stelle = stelle + 1
'Zeile 1 ist Übeschrift
For i = 2 To .AutoFilter.Range.Rows.Count
eintrag = False
.Range.AutoFilter Field:=1
If UBound(Filter(liste, "x" & CStr(daten(i, 1)) & "x", , vbBinaryCompare)) = -1 Then
For j = 2 To .AutoFilter.Range.Columns.Count
If ActiveSheet.Rows(i + 1).Hidden = False Then eintrag = True
Next j
If eintrag = True Then
liste(0) = liste(0) + 1
ReDim Preserve liste(liste(0))
liste(liste(0)) = "x" & CStr(daten(i, 1)) & "x"
End If
End If
Next
If stelle > UBound(liste) Then stelle = 0
If stelle = 0 Then
.Range.AutoFilter Field:=1
Exit Sub
End If
.Range.AutoFilter Field:=1, Criteria1:=Replace(Replace(liste(stelle), "x", ""), ",", ".")
End With
Application.ScreenUpdating = True
End Sub
Sub erster()
Dim liste()
Dim daten()
ReDim liste(0)
Dim i As Long
Dim j As Long
Dim eintrag As Boolean
With ActiveSheet.ListObjects("Auftragsliste")
Application.ScreenUpdating = False
daten = Range(.AutoFilter.Range.Address)
'Zeile 1 ist Übeschrift
For i = 2 To .AutoFilter.Range.Rows.Count
eintrag = False
.Range.AutoFilter Field:=1
If UBound(Filter(liste, "x" & CStr(daten(i, 1)) & "x", , vbBinaryCompare)) = -1 Then
For j = 2 To .AutoFilter.Range.Columns.Count
If ActiveSheet.Rows(i + 1).Hidden = False Then eintrag = True
Next
If eintrag = True Then
liste(0) = liste(0) + 1
ReDim Preserve liste(liste(0))
liste(liste(0)) = "x" & CStr(daten(i, 1)) & "x"
End If
End If
Next
If UBound(liste) > 0 Then
stelle = 1
Else
Exit Sub
End If
.Range.AutoFilter Field:=1, Criteria1:=Replace(Replace(liste(stelle), "x", ""), ",", ".")
End With
Application.ScreenUpdating = True
End Sub
Sub alle_leeren()
Debug.Print ActiveSheet.ListObjects.Count
ActiveSheet.ListObjects("Auftragsliste").AutoFilter.ShowAllData
stelle = 0
End Sub
|