Auslesen+Kopieren+3-fach

Sub Suche()
Dim strDateiname As String, strFirst As String, strDateipfad As String
Dim iDateien As Integer
Dim wks As Worksheet
Dim rFinde As Range, rSuche As Range
Dim lReihe As Long, letzte as Long
Application.ScreenUpdating = False
With Application.FileSearch
On Error Resume Next
.NewSearch
.LookIn = "C:\Kindersport\2007" ' Hier kann man den Pfad verändern
.Filename = "*.xls"
If .Execute() > 0 Then
For iDateien = 1 To .FoundFiles.Count
strDateiname = Dir(.FoundFiles(iDateien))
strDateipfad = .FoundFiles(iDateien)
If strDateiname  ThisWorkbook.Name Then
Workbooks.Open Filename:=.FoundFiles(iDateien)
For Each wks In ActiveWorkbook.Worksheets
Set rFinde = wks.Range("A:A")
Set rSuche = rFinde.Find(what:="Kindersport", LookAt:=xlPart, MatchCase:= _
_
_
False)
If Not rSuche Is Nothing Then
strFirst = rSuche.Address
Do
lReihe = rSuche.Row
If ThisWorkbook.Sheets(1).Range("A65536") = "" Then
wks.Range("A" & lReihe).EntireRow.Copy ThisWorkbook.Sheets(1).Range( _
_
" A65536").End(xlUp).Offset(1, 0)
With ThisWorkbook.Sheets(1)
letzte = IIf(IsEmpty(.Cells(Rows.Count, 1)),.Cells(Rows.Count, 1). _
_
End(xlUp).Row, Rows.Count)
End with
wks.Range("J2").Copy ThisWorkbook.Sheets(1).Range("Y" & letzte)
Else
MsgBox "Das Tabellenblatt ist voll! Es wird abgebrochen!",  _
vbExclamation, _
"Abbruch"
ActiveWorkbook.Close
Exit Sub
End If
Set rSuche = rFinde.FindNext(rSuche)
Loop While Not rSuche Is Nothing And rSuche.Address  strFirst
End If
Set rFinde = Nothing
Set rSuche = Nothing
Next wks
ActiveWorkbook.Close
End If
Next
End If
On Error GoTo 0
End With
Application.ScreenUpdating = True
End Sub