Hallo Johnny,
wenn ich das alles richtig verstanden habe dann so:
Option Explicit
Sub Suchen()
Application.ScreenUpdating = False
Sheets("Tabelle1").Select
Dim c, firstAddress
Dim strSuch As String, rngBer As Range
Set rngBer = Range("A3:A" & Range("A65536").End(xlUp).Row)
With rngBer
strSuch = Sheets("Tabelle3").Range("A5").Value
If strSuch = "" Then
Exit Sub
End If
Set c = .Find(strSuch, LookIn:=xlValues)
If c Is Nothing Then
MsgBox "Eintrag nicht vorhanden"
Else
firstAddress = c.Address
Do
c.Activate
Loop While Not c Is Nothing And c.Address <> firstAddress
Sheets("Tabelle1").Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 9)).Copy
Sheets("Tabelle2").Select
Range("A65536").End(xlUp).Select
Cells(ActiveCell.Row + 1, ActiveCell.Column).PasteSpecial
Range("A65536").End(xlUp).Select
Application.CutCopyMode = False
Sheets("Tabelle1").Select
Cells(ActiveCell.Row + 0, ActiveCell.Column + 1) = Sheets("Tabelle3").Range("B5").Value
Cells(ActiveCell.Row + 0, ActiveCell.Column + 6) = Sheets("Tabelle3").Range("G5").Value
Cells(ActiveCell.Row + 0, ActiveCell.Column + 9) = Sheets("Tabelle3").Range("J5").Value
Sheets("Tabelle3").Range("A5:J5").Copy
Sheets("Tabelle2").Select
Range("A65536").End(xlUp).Select
Cells(ActiveCell.Row + 2, ActiveCell.Column - 0).PasteSpecial
Application.CutCopyMode = False
Sheets("Tabelle3").Select
End If
End With
End Sub
Gruß
fedjo