Hallo Rudolf,
es wird das Filterergebnis, ohne die Überschriftenzeile, in "Tabelle2" kopiert. Das Tabellenblatt muss schon angelegt sein, sonst läuft der Code in einen Fehler.
Private Sub CommandButton1_Click()
Dim boFund As Boolean
Dim loLetzte As Long
Dim strNummerA As String
Dim strNummerB As String
Dim strVorname As String
Dim strNachname As String
Dim strWohnort As String
Dim strGeschlecht As String
Application.ScreenUpdating = False
With Worksheets("Tabelle1") 'anpassen
'## Ermitteln der letzten belegten Zelle in Spalte A
loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row
'## Variablen mit den Daten aus den Textboxen füllen
strNummerA = Me.NummerA
strNummerB = Me.NummerB
strVorname = Me.Vorname
strNachname = Me.Nachname
strWohnort = Me.Wohnort
strGeschlecht = Me.Geschlecht
'## Wenn gefiltert, dann alle Daten anzeigen
If .AutoFilterMode Then .AutoFilter.ShowAllData
'## Autofilter setzen
.Range("$A$1:$F$" & loLetzte).AutoFilter
'## Wenn Werte in den Variablen, dann danach filtern
If Not strNummerA = vbNullString Then
.Range("$A$1:$F$" & loLetzte).AutoFilter Field:=1, Criteria1:=strNummerA
boFund = True
End If
If Not strNummerB = vbNullString Then
.Range("$A$1:$F$" & loLetzte).AutoFilter Field:=2, Criteria1:=strNummerB
voFund = True
End If
If Not strVorname = vbNullString Then
.Range("$A$1:$F$" & loLetzte).AutoFilter Field:=3, Criteria1:=strVorname
boFund = True
End If
If Not strNachname = vbNullString Then
.Range("$A$1:$F$" & loLetzte).AutoFilter Field:=4, Criteria1:=strNachname
boFund = True
End If
If Not strWohnort = vbNullString Then
.Range("$A$1:$F$" & loLetzte).AutoFilter Field:=5, Criteria1:=strWohnort
boFund = True
End If
If Not strGeschlecht = vbNullString Then
.Range("$A$1:$F$" & loLetzte).AutoFilter Field:=6, Criteria1:=strGeschlecht
boFund = True
End If
If Worksheets("Tabelle1").AutoFilter.Range.Columns(1) _
.SpecialCells(xlCellTypeVisible).Cells.Count = 1 Then
MsgBox "Suchbegriff nicht gefunden"
If .AutoFilterMode Then .AutoFilterMode = False
Exit Sub
Else
With .AutoFilter.Range
If boFund Then
.Resize(.Rows.Count - 1).Offset(1, 0).Copy
Worksheets("Tabelle2").Cells(1, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
boFund = False
End If
End With
End If
If .AutoFilterMode Then .AutoFilterMode = False
End With
'## Userform schließen
Unload Me
Application.ScreenUpdating = True
End Sub
Gruß Werner
|