SuchFindenKopieren VBA umschreiben

Computer: Software & Programmierung Office Software
1

Hallo,
der folgende Code sucht bestimmte Begriffe aus Tabelle 1 und kopiert die gefunden Ergebnisse in Tabbelle 2.

FRAGEN:
Wie kann man den Code so ändern, daß die Suchbegriffe nicht mehr abgefragt werden, sondern gesuchte Begriffe stehen in „mehreren Zellen“ ??
Diese werden, dann nacheinander in Tabelle 2 angezeigt.

Danke für jede Hilfe.
MFG
Xen55

Sub SuchenKopieren()
'Sucht Begriff in Spalte A der Quelle und kopiert Zeile in Zieltabelle
Dim wksQuelle As Worksheet, wksZiel As Worksheet, Suchen As Variant, Finden As Range
Dim Addresse1 As String
Set wksQuelle = ActiveWorkbook.Worksheets(„Tab1“)
Set wksZiel = ActiveWorkbook.Worksheets(„Tab2“)
Zeile = 2 'Zeile in Zieltabelle an der kopierte Zeile eingefügt werden soll
Suchen = InputBox(„Gesuchter Wert?“, „Suchen und Kopieren“)
If Suchen = „“ Then Exit Sub 'Abbrechen geklickt
On Error GoTo Fehler
Suchen = CDbl(Suchen) 'Diese Zeile und unten die Fehlermeldung löschen wenn Texte gesucht werden sollen
Set Finden = wksQuelle.Columns(1).Find(What:=Suchen, LookIn:=xlValues, Lookat:=xlWhole, Searchorder:=xlByColumns)
If Finden Is Nothing Then
MsgBox „Wert nicht gefunden“
Else
Adresse1 = Finden.Address
Do
wksQuelle.Rows(Finden.Row).Copy
wksZiel.Paste Destination:=wksZiel.Cells(Zeile, 1) 'Zielzeile wird überschrieben
’ wksZiel.Cells(Zeile, 1).Insert Shift:=xlShiftDown 'kopierte Zeile wird eingefügt
Set Finden = wksQuelle.Columns(1).FindNext(After:=Finden)
Zeile = Zeile + 1
Loop Until Finden.Address = Adresse1 Or Finden Is Nothing
Application.CutCopyMode = False
End If
wksZiel.Select
Exit Sub
Fehler:
MsgBox („Suchbegriff ist keine Zahl“)
End Sub

2

Wie kann man den Code so ändern, daß die Suchbegriffe nicht
mehr abgefragt werden, sondern gesuchte Begriffe stehen in
„mehreren Zellen“ ??
Diese werden, dann nacheinander in Tabelle 2 angezeigt.

Hi Xen55,
In A von Tab3 stehen di Suchbegriffe.

Option Explicit

Sub SuchenKopieren()
'Sucht Begriff in Spalte A der Quelle und kopiert Zeile in Zieltabelle
Dim wksQuelle As Worksheet, wksZiel As Worksheet, wksSuch As Worksheet, Suchen, Finden As Range
Dim Zeile As Long, Zelle As Range, ZeiFind As Long
Set wksQuelle = ActiveWorkbook.Worksheets("Tab1")
Set wksZiel = ActiveWorkbook.Worksheets("Tab2")
Set wksSuch = ActiveWorkbook.Worksheets("Tab3")
Zeile = 1
wksQuelle.Activate
For Each Zelle In wksSuch.Range("A1:A" & wksSuch.Range("A65536").End(xlUp).Row)
 On Error GoTo FehlerZahl
 Suchen = CDbl(Zelle)
 On Error GoTo FehlerSuch
 ZeiFind = Application.WorksheetFunction.Match(Suchen, wksQuelle.Columns("A:A"), 0)
 On Error GoTo 0
 Zeile = Zeile + 1
 wksQuelle.Range(Cells(ZeiFind, 1), Cells(ZeiFind, 256)).Copy Destination:=wksZiel.Cells(Zeile, 1)
Next Zelle
Application.CutCopyMode = False
wksZiel.Activate
Exit Sub
FehlerZahl:
MsgBox Zelle.Value & " ist keine Zahl"
Resume Next
FehlerSuch:
MsgBox Suchen & " wurde nicht gefunden"
Resume Next
End Sub

Gruß
Reinhard