Leere Filtern funktioniert nicht - wo Fehler?
04.12.2008 18:50:00
Wolfgang
der nachstehende Code bewirkt ein Filtern über 16 Spalten bzw. Boxes; Ich würde ihn gerne, wie im Autofilter, ergänzen um (Leere), (Nichtleere) und (Alle). Ich habe, nach Hinweisen auf dem Forum, vor geraumer Zeit den Code versucht, anzupassen. Irgendwie ist aber noch ein Fehler darin, weil er die Leeren doch nicht filtert. Hat da evtl. jemand den Blick dafür, was da im Code noch falsch sein kann? - Könnte ich RowSource, siehe auch unten, evtl. direkt noch um den Text (Leere) etc. eränzen? Danke schon jetzt wieder für die Rückmeldungen.
Herzliche Grüße
Wolfgang
Private Sub Gesamt()
' Variablendeklaration
Dim intCounter As Integer
Dim shSource As Worksheet
Dim lngRow As Long
Dim wb As Workbook
Dim sport As String
Dim fd As FileDialog
Dim vrtSelectedItem As Variant
Set shSource = Sheets("Gesamt")
For intCounter = 1 To 16
'Wenn eine Auswahl erfolgte, dann
If Controls("cbbKriterium" & intCounter).ListIndex -1 Then
'Kriterium festlegen
Select Case Controls("cbbKriterium" & intCounter).Value
Case "(Alle)"
shSource.Range("A1").Autofilter Field:=intCounter '(Alle) anzeigen
Case "(Leere)", ""
shSource.Range("A1").Autofilter Field:=intCounter, Criteria1:="=" '(Leere) filtern
Case "(NichtLeere)"
shSource.Range("A1").Autofilter Field:=intCounter, Criteria1:="" '(Nichtleere) _
filtern
Case Else
If intCounter = 3 Then
shSource.Range("A1").Autofilter Field:=intCounter, _
Criteria1:=CDate(Controls("cbbKriterium" & intCounter).Value)
Else
shSource.Range("A1").Autofilter Field:=intCounter, _
Criteria1:=Controls("cbbKriterium" & intCounter).Value
End If
End Select
End If
Next intCounter
' Alle sichtbaren Zellen kopieren
shSource.Range("A1").CurrentRegion.Copy
' Neues Arbeitsblatt hinzufügen
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Paste
' Autofilter ausschalten
shSource.Range("A1").Autofilter
' Kopiermodus ausschalten
Application.CutCopyMode = False
Range("A1").Select
'wb.Activate
'Rows("1:1").Select
' Dialog beenden
Unload Me
Set fd = Nothing
End Sub
' RowSource für die 16 Comboboxes
Private Sub KritGesamt()
cbbKriterium1.RowSource = "Gesamt!a2:a6000"
cbbKriterium2.RowSource = "Gesamt!b2:b6000"
cbbKriterium3.RowSource = "Gesamt!c2:c6000"
cbbKriterium4.RowSource = "Gesamt!d2:d6000"
cbbKriterium5.RowSource = "Gesamt!e2:e6000"
cbbKriterium6.RowSource = "Gesamt!f2:f6000"
cbbKriterium7.RowSource = "Gesamt!g2:g6000"
cbbKriterium8.RowSource = "Gesamt!h2:h6000"
cbbKriterium9.RowSource = "Gesamt!i2:i6000"
cbbKriterium10.RowSource = "Gesamt!j2:j6000"
cbbKriterium11.RowSource = "Gesamt!k2:k6000"
cbbKriterium12.RowSource = "Gesamt!l2:l6000"
cbbKriterium13.RowSource = "Gesamt!m2:m6000"
cbbKriterium14.RowSource = "Gesamt!n2:n6000"
cbbKriterium15.RowSource = "Gesamt!o2:o6000"
cbbKriterium16.RowSource = "Gesamt!p2:p6000"
End Sub
Anzeige