|
Sorry, gab noch nen Fehler! Aber nu:
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
For i = 2 To .AutoFilter.Range.Columns.Count
If filterwerte(i) <> "" Then .Range.AutoFilter Field:=i, Criteria1:=filterwerte(i)
Next i
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
For i = 2 To .AutoFilter.Range.Columns.Count
If filterwerte(i) <> "" Then .Range.AutoFilter Field:=i, Criteria1:=filterwerte(i)
Next i
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
|