Hallo,

wenn du nach deinem Abschluss in die Wissenschaft gehen möchtest, dann musst du schnell lernen, nicht so schnell zu urteilen:

"Wow das ist voll lieb, so viel mühe. Aber leider geht es nicht, der Code hat leider mehr Fehler als zuvor"

Aber ich glaube für die Praxis ist eine so forsche Art nicht schlecht ;-) . Wie viele Fehler hast du denn in dem von mir angepassten Code gefunden? Ich habe ihn gerade mal kurz getestet: ich musste ein "End Width" einfügen und dann hat er das gemacht, von dem ich so halbwegs glaube, dass du es haben möchtest.

"Meinen Code habe ich repariert aber er macht dann den kopier prozess nicht und spring zurück zu "For" "

Wenn du deine "Reparatur" posten würdest, dann könnte man dir vielleicht helfen, sie zu verbessern. So ist das eine für mich nicht hilfreiche, unnütze, in sich widersprüchliche Behauptung.

Daher hier nochmals der von mir angepasste Code, der jetzt um die Zeile "End Width" korrigiert wurde.

Sub Mehrere_Dateien_einlesen()
Dim strFile As String
Dim i As Long
Dim fldr As FileDialog

'Opens All Subfolders and lists them in the Activeworksheet
 Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
 fldr.Show
 f = fldr.SelectedItems(1)
 f = f & "\"
 ibox = "*.xls*"    'InputBox("File Must Contain (Note * wildcards can be used) ", , "*.xls*")
 On Error Resume Next
 sn = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & f & ibox & """ /s /a /b").stdout.readall, vbCrLf)
' Sheets(1).Cells(1).Resize(UBound(sn) + 1) = Application.Transpose(sn)     'write Path- and Filenames to worksheet
 On Error GoTo 0
    
    
For i = 0 To UBound(sn) - 1 'Schleife über alle Dateinamen in sn
    strFile = sn(i)         'Dateiname
    
    With Workbooks.Open(Filename:=strFile) ' Opens File

        If BlattExist(.Sheets(1).Parent, "Beutel(bag)") Then ' <-- Enter the Worksheet that includes the Data
            
            .Worksheets("Beutel(bag)").Range("B73,F73:I73,B90,F90:I90,B91,F91:I91").Copy '<-- Enter Cells that include the Data

            sBlattName = Left(Dir(strFile), 31)             'Sheetname = Filename (if Name exceeds 31 Characters, it will be shortened)

            MsgBox "Found Data copying will be done"

            ThisWorkbook.Worksheets.Add().Name = sBlattName
            ThisWorkbook.Worksheets(sBlattName).Range("A1").PasteSpecial Paste:=xlValues
            Application.CutCopyMode = False 'deletes the copy buffer


        Else
            MsgBox "File doesnt include Worksheet ""Beutel(bag)"""
        End If

    .Close False        'Datei schließen
    
    End With

Next

End Sub

'Function of checking the existance of a Worksheet
Function BlattExist(wb As Workbook, strBlatt As String) As Boolean
Dim shDummy

   On Error Resume Next: Err.Clear
   Set shDummy = wb.Sheets(strBlatt)
   If Err.Number = 0 Then
      BlattExist = True
   End If
End Function

Ich habe dein Konstrukt weitestgehend so belassen wie es ist (ich finde es nicht sinnvoll).

Grüße, Ulrich