Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1484to1488
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Auswählen und Kopieren mit mehreren Suchwerten

Auswählen und Kopieren mit mehreren Suchwerten
13.04.2016 12:30:35
Richard
Hallo Leute
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

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Auswählen und Kopieren mit mehreren Suchwerten
13.04.2016 13:03:42
Rudi
Hallo,
teste mal:
Sub ElternundBetreuer()
Range(Rows(3), Rows(Rows.Count)).Delete
Dim Suche As String
Suche = "Betreuer|Eltern"
MsgBox ("Es wurden " & AuswahlKopierenIII(Suche, True) & " Zeilen kopiert!")
End Sub
Function AuswahlKopierenIII(SuchStrA 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
Dim SuchStr As String
Dim i As Integer
'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 SuchStrA  "" Then
For i = 0 To UBound(Split(SuchStrA, "|"))
SuchStr = Split(SuchStrA, "|")(i)
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
Next i
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

Gruß
Rudi

Anzeige
AW: Auswählen und Kopieren mit mehreren Suchwerten
14.04.2016 09:39:07
Richard
Das war es :-)
und ich weiß nun auch wie ich zwei Begriffe bei der Deklaration reinbekomme.
Vielen Dank

AW: Auswählen und Kopieren mit mehreren Suchwerten
13.04.2016 13:18:37
UweD
Hallo
Notfalls indem du 2. suchst.

Option Explicit
Sub ElternundBetreuer()
With Worksheets("Eltern und Betreuer")
.Range(.Rows(3), .Rows(Rows.Count)).Delete
Dim Suche1 As String
Dim Suche2 As String
Suche1 = "Betreuer"
Suche2 = "Eltern"
MsgBox ("Es wurden " & AuswahlKopierenIII(Suche1, Suche2, True) & " Zeilen kopiert!")
End With
End Sub
Function AuswahlKopierenIII(SuchStr1 As String, SuchStr2 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 FRng1           As Range
Dim FRng2           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 SuchStr1  "" And SuchStr2  "" Then
If Ganz Then
Set FRng1 = .Find(SuchStr1, LookIn:=xlValues, LookAt:=xlWhole)
Else
Set FRng1 = .Find(SuchStr1, LookIn:=xlValues, LookAt:=xlPart)
End If
If Not FRng1 Is Nothing Then
FirstAdr = FRng1.Address
Do
If CRng Is Nothing Then
Set CRng = WSq.Rows(FRng1.Row)
Else
Set CRng = Union(WSq.Rows(FRng1.Row), CRng)
End If
Set FRng1 = .FindNext(FRng1)
Loop While Not FRng1 Is Nothing And FRng1.Address  FirstAdr
End If
If Ganz Then
Set FRng2 = .Find(SuchStr2, LookIn:=xlValues, LookAt:=xlWhole)
Else
Set FRng2 = .Find(SuchStr2, LookIn:=xlValues, LookAt:=xlPart)
End If
If Not FRng2 Is Nothing And SuchStr2  "" Then
FirstAdr = FRng2.Address
Do
If CRng Is Nothing Then
Set CRng = WSq.Rows(FRng2.Row)
Else
Set CRng = Union(WSq.Rows(FRng2.Row), CRng)
End If
Set FRng2 = .FindNext(FRng2)
Loop While Not FRng2 Is Nothing And FRng2.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
Fruß UweD
Anzeige

306 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige