|
Moin! Dann mal so probieren. Habe den WErt anders ermittelt. Viele Wege führen ja nach Rom. :-) 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
ReDim filterwerte(ActiveSheet.AutoFilter.Range.Columns.Count)
'nur das erste Kriterium
For i = 2 To ActiveSheet.AutoFilter.Range.Columns.Count
If ActiveSheet.AutoFilter.Filters(i).On Then
filterwerte(i) = Right(ActiveSheet.AutoFilter.Filters(i).Criteria1, Len(ActiveSheet.AutoFilter.Filters(i).Criteria1) - 1)
Else
filterwerte(i) = ""
End If
Next i
daten = Range(ActiveSheet.AutoFilter.Range.Address)
stelle = stelle - 1
If ActiveSheet.AutoFilterMode = True Then
'Zeile 1 ist Übeschrift
For i = 2 To ActiveSheet.AutoFilter.Range.Rows.Count
eintrag = True
If UBound(Filter(liste, CStr(daten(i, 1)), , vbBinaryCompare)) = -1 Then
For j = 2 To ActiveSheet.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)) = CStr(daten(i, 1))
End If
End If
Next
If stelle = -1 Then stelle = UBound(liste)
If stelle = 0 Then
Range("Auftragsliste").AutoFilter Field:=1
Exit Sub
End If
Range("Auftragsliste").AutoFilter Field:=1, Criteria1:=Replace(liste(stelle), ",", ".")
Else
ActiveSheet.AutoFilterMode
End If
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
ReDim filterwerte(ActiveSheet.AutoFilter.Range.Columns.Count)
'nur das erste Kriterium
For i = 2 To ActiveSheet.AutoFilter.Range.Columns.Count
If ActiveSheet.AutoFilter.Filters(i).On Then
filterwerte(i) = Right(ActiveSheet.AutoFilter.Filters(i).Criteria1, Len(ActiveSheet.AutoFilter.Filters(i).Criteria1) - 1)
Else
filterwerte(i) = ""
End If
Next i
daten = Range(ActiveSheet.AutoFilter.Range.Address)
stelle = stelle + 1
If ActiveSheet.AutoFilterMode = True Then
'Zeile 1 ist Übeschrift
For i = 2 To ActiveSheet.AutoFilter.Range.Rows.Count
eintrag = True
If UBound(Filter(liste, CStr(daten(i, 1)), , vbBinaryCompare)) = -1 Then
For j = 2 To ActiveSheet.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)) = CStr(daten(i, 1))
End If
End If
Next
If stelle > UBound(liste) Then stelle = 0
If stelle = 0 Then
Range("Auftragsliste").AutoFilter Field:=1
Exit Sub
End If
Range("Auftragsliste").AutoFilter Field:=1, Criteria1:=Replace(liste(stelle), ",", ".")
Else
Range("Auftragsliste").AutoFilter
End If
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
ReDim filterwerte(ActiveSheet.AutoFilter.Range.Columns.Count)
'nur das erste Kriterium
For i = 2 To ActiveSheet.AutoFilter.Range.Columns.Count
If ActiveSheet.AutoFilter.Filters(i).On Then
filterwerte(i) = Right(ActiveSheet.AutoFilter.Filters(i).Criteria1, Len(ActiveSheet.AutoFilter.Filters(i).Criteria1) - 1)
Else
filterwerte(i) = ""
End If
Next i
daten = Range(ActiveSheet.AutoFilter.Range.Address)
If ActiveSheet.AutoFilterMode = True Then
'Zeile 1 ist Übeschrift
For i = 2 To ActiveSheet.AutoFilter.Range.Rows.Count
eintrag = True
If UBound(Filter(liste, CStr(daten(i, 1)), , vbBinaryCompare)) = -1 Then
For j = 2 To ActiveSheet.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)) = CStr(daten(i, 1))
End If
End If
Next
If UBound(liste) > 0 Then
stelle = 1
Else
Exit Sub
End If
Range("Auftragsliste").AutoFilter Field:=1, Criteria1:=Replace(liste(stelle), ",", ".")
Else
Range("Auftragsliste").AutoFilter
End If
End Sub
Sub alle_leeren()
If ActiveSheet.AutoFilterMode = True Then Range("Auftragsliste").AutoFilter
Range("Auftragsliste").AutoFilter
stelle = 0
End Sub
|