Dim FileName(1 To 2000) As String
Dim MaxTab As Integer
Sub Main()
    Call Msg
    Call Scopy
End Sub


Sub Scopy()
        ChDir "D:\*****\******\"
'
    For I = 1 To MaxTab
        Workbooks.Open FileName:=FileName(I)
        Application.CutCopyMode = False
        Range("A5:A5").Select
        Selection.Value = ActiveWorkbook.Name
        Range("A5").Select
        Text1 = ActiveCell.Value
        Range("B5:L12").Select
        Selection.Copy
        Windows("[b]test lücken.xls[/b]").Activate
        Zeile = (5 + (I - 1) * 8)
        Range(Cells(Zeile, 2), Cells(Zeile, 12)).Select
        ActiveSheet.Paste
        Range(Cells(Zeile, 1), Cells(Zeile, 1)).Select
        ActiveCell.Value = Text1
    Next I
End Sub
Sub Msg()
    Set fs = Application.FileSearch
With fs
    .LookIn = "D:\****\*****\"
    .FileName = "*.xls"
            MaxTab = fs.FoundFiles.Count
    If .Execute(SortBy:=msoSortByFileName) > 0 Then
        For I = 1 To .FoundFiles.Count
'          MsgBox .FoundFiles(I)
            FileName(I) = fs.FoundFiles(I)
        Next I
    Else
        MsgBox "There were no files found."
    End If
End With
End Sub