der untenstehende Code befindet sich hinter einem UF und bewirkt das Filtern von Daten der jeweils aktiven Tabelle. Nun würde ich den Vorgang gerne umstellen und den UF über eine Startseite aufrufen. Dabe würde ich dann gerne im UF vorbestimmen, ob die Daten aus der Tabelle "alt" oder aus der Tabelle "neu" oder aus beiden Tabellen gefiltert werden sollen. Weiterhin würde ich dann gerne erreichen, dass die gefilterten Daten innerhalb der Mappe in eine jeweils neue Tabelle die den jeweiligen Namen der Abfrage erhalten "Ergebnis alt", "Ergebnis neu", "Ergebnis alt und neu" kopiert werden und nicht mehr in eine neue Mappe. Bislang hat mir Excel dabei auch nicht die Überschrift, die sich in Zeile 1 befindet übernommen, wäre die Ergänzung auch denkbar?
Habe schon verschiedene Umstellungen versucht, komme dabei aber nicht weiter und wäre für jede Hilfestellung sehr dankbar.
Herzliche Grüße
Wolfgang
'*** Filterkritrien festlegen und filtern ***
Private Sub cmdFiltern_Click()
' 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 = ActiveSheet
' Schleife über 15 TextBoxes
For intCounter = 1 To 15
'Wenn eine Auswahl erfolgte, dann
If Controls("cbbKriterium" & intCounter).ListIndex -1 Then
'Kriterium festlegen
If intCounter = 3 Then
Range("A1").Autofilter Field:=intCounter, _
Criteria1:=CDate(Controls("cbbKriterium" & intCounter).Value)
Else
Range("A1").Autofilter Field:=intCounter, _
Criteria1:=Controls("cbbKriterium" & intCounter).Value
End If
End If
Next intCounter
' Alle sichtbaren Zellen kopieren
Range("A1").CurrentRegion.Copy
' Neues Arbeitsblatt hinzufügen
Set wb = Workbooks.Add(1)
ActiveSheet.Paste
' Autofilter ausschalten
shSource.Range("A1").Autofilter
' Kopiermodus ausschaltern
Application.CutCopyMode = False
' Zwischenspeicher einfügen
' Zelle A1 auswählen
Range("A1").Select
wb.Activate
Rows("1:1").Select
Selection.Delete Shift:=xlUp
' Dialog beenden
Unload Me
Set fd = Nothing
End Sub