Moin! Also habe jetzt mal die Datei auf nem neuen System und mit der Originaldatei getestet. Musste nun feststellen, dass deine Auflistung als Tabelle formatiert ist. Da ging der Code nicht. Habe es jetzt mal angepasst und probiert. Läuft jetzt. Wie immer bitte mal testen. Falls du den Button zum Leeren noch mit aufnehmen willst, der Code stimmt jetzt auch. Schicke die Originaldatei heute Abend noch als link. Kann von hier aber nichts hochladen. VG
Option Explicit
Dim stelle As Long
Sub filter_zurück()
Dim liste()
Dim daten()
Dim filterwerte()
ReDim liste(0)
Dim i As Long
Dim j As Long
Dim eintrag As Boolean
With ActiveSheet.ListObjects("Auftragsliste")
ReDim filterwerte(.AutoFilter.Range.Columns.Count)
'nur das erste Kriterium
For i = 2 To .AutoFilter.Range.Columns.Count
If .AutoFilter.Filters(i).On Then
filterwerte(i) = Right(.AutoFilter.Filters(i).Criteria1, Len(.AutoFilter.Filters(i).Criteria1) - 1)
Else
filterwerte(i) = ""
End If
Next i
daten = Range(.AutoFilter.Range.Address)
stelle = stelle - 1
'Zeile 1 ist Übeschrift
For i = 2 To .AutoFilter.Range.Rows.Count
eintrag = True
If UBound(Filter(liste, "x" & CStr(daten(i, 1)) & "x", , vbBinaryCompare)) = -1 Then
For j = 2 To .AutoFilter.Range.Columns.Count
If filterwerte(j) <> "" Then
If CStr(daten(i, j)) <> filterwerte(j) Then eintrag = False
End If
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
End Sub
Sub filter_vor()
Dim liste()
Dim daten()
Dim filterwerte()
ReDim liste(0)
Dim i As Long
Dim j As Long
Dim eintrag As Boolean
With ActiveSheet.ListObjects("Auftragsliste")
ReDim filterwerte(.AutoFilter.Range.Columns.Count)
'nur das erste Kriterium
For i = 2 To .AutoFilter.Range.Columns.Count
If .AutoFilter.Filters(i).On Then
filterwerte(i) = Right(.AutoFilter.Filters(i).Criteria1, Len(.AutoFilter.Filters(i).Criteria1) - 1)
Else
filterwerte(i) = ""
End If
Next i
daten = Range(.AutoFilter.Range.Address)
stelle = stelle + 1
'Zeile 1 ist Übeschrift
For i = 2 To .AutoFilter.Range.Rows.Count
eintrag = True
If UBound(Filter(liste, "x" & CStr(daten(i, 1)) & "x", , vbBinaryCompare)) = -1 Then
For j = 2 To .AutoFilter.Range.Columns.Count
If filterwerte(j) <> "" Then
If CStr(daten(i, j)) <> filterwerte(j) Then eintrag = False
End If
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
End Sub
Sub erster()
Dim liste()
Dim daten()
Dim filterwerte()
ReDim liste(0)
Dim i As Long
Dim j As Long
Dim eintrag As Boolean
With ActiveSheet.ListObjects("Auftragsliste")
ReDim filterwerte(.AutoFilter.Range.Columns.Count)
'nur das erste Kriterium
For i = 2 To .AutoFilter.Range.Columns.Count
If .AutoFilter.Filters(i).On Then
filterwerte(i) = Right(.AutoFilter.Filters(i).Criteria1, Len(.AutoFilter.Filters(i).Criteria1) - 1)
Else
filterwerte(i) = ""
End If
Next i
daten = Range(.AutoFilter.Range.Address)
'Zeile 1 ist Übeschrift
For i = 2 To .AutoFilter.Range.Rows.Count
eintrag = True
If UBound(Filter(liste, "x" & CStr(daten(i, 1)) & "x", , vbBinaryCompare)) = -1 Then
For j = 2 To .AutoFilter.Range.Columns.Count
If filterwerte(j) <> "" Then
If CStr(daten(i, j)) <> filterwerte(j) Then eintrag = False
End If
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 UBound(liste) > 0 Then
stelle = 1
Else
Exit Sub
End If
.Range.AutoFilter Field:=1, Criteria1:=Replace(Replace(liste(stelle), "x", ""), ",", ".")
End With
End Sub
Sub alle_leeren()
Debug.Print ActiveSheet.ListObjects.Count
ActiveSheet.ListObjects("Auftragsliste").AutoFilter.ShowAllData
stelle = 0
End Sub
|