|
Moin Louis! Also der Filter hat mich jetzt eine geraume Zeit gekostet. Kann aber glaube ich nicht wirklich mit einer zufriedenstellenden Lösung aufwarten. :-( In den neuen Excelversionen wird beim Datum immer schon ein Arrayformat genommen. D.h. es wird erst das Jahr , versetzt der Monat und dann die Tage angezeigt, aus denen man wählen kann. Dies liest die Daten in ein Array. Leider konnte ich bisher keinen Zugriff auf dieses Array erlangen und in div. Foren hab ich auch nichts gefunden. Zudem verwirrt mich der Makrorecorder, da anscheinend dann nur ein zweiten Criterium aber kein erstes gesetzt wird. Also mit eingeschränkter Funktionalität würde es gehen, wenn du den Filter da nicht nutzt sondern statt dessen auf den Datumsfilter darüber und dort auf ist gleich gehen und dann das Datum eintragen. Dann läuft er. Der Code unten dazu nochmal (ich glaube zwar, dass sich nix geändert hat, bin mir aber nicht sicher). UNd zu der Formel hier
=[@[10,00 €]]*[@8]
Sollet es auch klappen. Weiß nicht genau, wie die zu Stande kommt und wo du die her hast???
Also Sorry nochmal. Ich schaue mal noch und wenn ich was finde, versuche ich nochmal das Problem zu beheben.
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
Dim kriterium
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
Debug.Print .AutoFilter.Filters(i).Criteria1
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
Debug.Print filterwerte(j)
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)
End If
Next i
Exit Sub
End If
kriterium = Replace(Replace(liste(stelle), "x", ""), ",", ".")
.Range.AutoFilter Field:=1, Criteria1:=kriterium
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
Dim test As Object
Dim kriterium
Dim filterneu
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
If filterwerte(i) <> "" Then
.Range.AutoFilter Field:=i, Criteria1:=filterwerte(i)
End If
End If
Next i
Exit Sub
End If
kriterium = Replace(Replace(liste(stelle), "x", ""), ",", ".")
.Range.AutoFilter Field:=1, Criteria1:=kriterium
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
Dim kriterium
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
kriterium = Replace(Replace(liste(stelle), "x", ""), ",", ".")
.Range.AutoFilter Field:=1, Criteria1:=kriterium
End With
End Sub
Sub alle_leeren()
Debug.Print ActiveSheet.ListObjects.Count
ActiveSheet.ListObjects("Auftragsliste").AutoFilter.ShowAllData
stelle = 0
End Sub
|