ich habe bereits zwei Funktionen mit Buttons. Meine Quelltabelle ("Eingabeliste") wird nach z.B. Betreuer durchsucht und die Zeilen in denen das Wort vorkommt werden in meiner Zieltabelle "Eltern und Betreuer" kopiert. Durch eine vorherige Löschfunktion, wird das immer wieder neu erstellt und ist somit aktuell.
Nun möchte ich aber das in der Quelltabelle nach zwei Begriffen gesucht wird nach Eltern und nach Betreuern und immer dann wenn einer der Begriffe vorkommt soll diese Zeile dann in meine Zieltabelle kopiert werden wie kann ich den folgenden Code abwandeln?
Sub ElternundBetreuer()
Range(Rows(3), Rows(Rows.Count)).Delete
Dim Suche As String
Suche = "Betreuer"
MsgBox ("Es wurden " & AuswahlKopierenIII(Suche, True) & " Zeilen kopiert!")
End Sub
Function AuswahlKopierenIII(SuchStr As String, Optional Ganz As Boolean = False) As Integer
'Wenn der SuchStr leer ("") ist, werden alle Zeilen der gefüllten Zellen kopiert...
'Mit Ganz=True wird der ganze Zellinhalt verglichen
'mit Ganz=False wird auch kopiert, wenn der Suchtext nur in der zelle vorkommt...
Dim WSq As Worksheet
Dim WSz As Worksheet
Dim SuchColRng As Range
Dim FRng As Range
Dim CRng As Range
Dim CRangeCustom As Range
Dim FirstAdr As String
Dim CArr As Variant
'Anpassen------------------------------
Set WSq = Worksheets("Eingabeliste") 'Arbeitsblatt, in der gesucht / aus der kopiert _
wird
Set SuchColRng = WSq.Range("B:D") 'Spalte, in der der Suchbegriff gesucht wird
Set CRangeCustom = WSq.Range("F:Z") 'Spalten die Kopiert werden sollen
Set WSz = Worksheets("Eltern und Betreuer") 'Arbeitsblatt, in das kopiert werden _
soll
'Anpassen------------------------------
With SuchColRng
If SuchStr "" Then
If Ganz Then
Set FRng = .Find(SuchStr, LookIn:=xlValues, LookAt:=xlWhole)
Else
Set FRng = .Find(SuchStr, LookIn:=xlValues, LookAt:=xlPart)
End If
If Not FRng Is Nothing Then
FirstAdr = FRng.Address
Do
If CRng Is Nothing Then
Set CRng = WSq.Rows(FRng.Row)
Else
Set CRng = Union(WSq.Rows(FRng.Row), CRng)
End If
Set FRng = .FindNext(FRng)
Loop While Not FRng Is Nothing And FRng.Address FirstAdr
End If
Else
Set CRng = SuchColRng.SpecialCells(xlCellTypeConstants).EntireRow
End If
End With
If Not CRng Is Nothing Then
Set CRng = Intersect(CRng, CRangeCustom)
CRng.Copy
WSz.Cells(WSz.Cells(WSz.Rows.Count, SuchColRng.Column).End(xlUp).Row + 1, 1). _
PasteSpecial xlPasteValues
Application.CutCopyMode = False
AuswahlKopierenIII = CRng.Cells.Count / CRng.Rows(1).Cells.Count
Else
AuswahlKopierenIII = 0
End If
End Function
Ziel ist es einmal dem Anwender nur eine Liste mit Eltern, eine Liste mit Betreuern und eine Liste mit beiden per klick anzubieten.Danke für die Hilfe