Anstatt neue Tabelle, Zählen und MsgBox
18.11.2008 19:45:00
Wolfgang
der untenstehende Code filtert über 16 Comboboxes, auf einem UF, die jeweils eingestellten Daten und legt ein neues Tabellenblatt innerhalb der Mappe an. Im Laufe des Arbeitens damit wird mir klar, dass ich nicht immer eine neue Tabelle benötige, sondern eigentlich nur die Zahl der jeweils gefilterten Datensätze bzw. Filtereinstellungen. Wie könnte der Code umgestellt werden, dass ich dieses Ziel erreichen kann. Schön wäre evtl. die jeweilige Überschrift der Abfrage und den Abfragetext in der MsgBox mit angezeigt zu bekommen. Konnte so wirklich zu meiner Fragestellung auf der CD und in Recherche nichts entdecken und wäre somit umsomehr für eine Hilfestellung dankbar.
Danke schon jetzt für die Rückmeldungen.
Herzliche Grüße
Wolfgang
Private Sub Grunddatenwahl()
' 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
'neue Tabelle für gefiltere Datensätze anlegen
' Objektvariable für aktives Blatt festlegen
Set shSource = Sheets("Grunddaten")
'shSource.Unprotect
' Schleife über 16 TextBoxes
For intCounter = 1 To 16
'Wenn eine Auswahl erfolgte, dann
If Controls("cbbKriterium" & intCounter).ListIndex -1 Then
'Kriterium festlegen
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 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
' Zwischenspeicher einfügen
' Zelle A1 auswählen
Range("A1").Select
' Dialog beenden
Unload Me
Set fd = Nothing
End Sub