Hallo,

mir scheint, als ob du hier zwei Codeschnipsel aneinander gefügt hast, die nichts miteinander zu tun haben (sollten).

Es ist auch stark davon abhängig, was du in die Inputbox eingibst. Ich gehe mal vom Default aus, also

*.xls*

. Mir steht gerade kein Excel zur Verfügung, doch ich versuche es trotzdem einmal:

Hiermit

 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)
 

werden Dateinamen inklusive Pfad in die erste Spallte eingetragen, z.B. "c:\test\test\Datei.xlsx"

Nun folgt

    strPath = ThisWorkbook.Worksheets(1).Cells(i, 1) '  <--Enter Path here
    strExt = "*.xlsx" ' <-- Enter Data Type you want to open

die Variable strPath hat also jetzt den Inhalt "c:\test\test\Datei.xlsx". Es folgt der Aufruf

        strFile = Dir(strPath & strExt)

dabei ergibt strPath & strExt "c:\test\test\Datei.xlsx*.xlsx". Diese Datei existiert nicht, daher gibt Dir("c:\test\test\Datei.xlsx*.xlsx") einen leeren String zurück.

Und das funktioniert nunmal nicht. Daher mein ungetesteter Vorschlag:

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.Add.Name = sBlattName   <= ich glaube, dass dies falsch ist, evtl. diese statt vorheriger Zeile benutzen
            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

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

wie gesagt: ungetestet! Funktioniert es?

Grüße, Ulrich