|
Und schon wieder ich. Also komme erst am Sonntag zum Testen und Feintunen. Falls du aber schonmal probieren willst, nach meinem Verständnis könnte / sollte folgender Code das auch machen. Am Sonntag Abend dann eine gestestete Version. 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
With ActiveSheet.ListObjects("Auftragsliste")
Application.ScreenUpdating = False
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
With ActiveSheet.ListObjects("Auftragsliste")
Application.ScreenUpdating = False
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 jj
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
|