Guten Tag, 

ich habe mir diesen Code unten gebastelt und nur noch ein kleines Problem zu lösen. Für jede Hilfe wäre ich  sehr dankbar. 
Der Code kriegt es nicht hin "strFile = Dir(strPath & strExt)" zu speichern.

StrFile bleibt leer. Woran liegt das? 
 

Kleine erklärung zum programm: 

Dieses Programm ist zur statistischen Datenerfassung. Man gibt einen Pfad an, welcher nach xlsx dateien durchsucht wird. Die ganzen gefundenen Dateien werden zunächst als Pfade in dem Activeworksheet eingefügt. Darauf werden diese einzeln geöffnet, nach einem bestimmten worksheet durchsucht und falls es vorhanden ist, werden die daten in einem neuerstellten Worksheet eingefügt. Das ganze wird gelooped. 

 

 

 

 

Sub Mehrere_Dateien_einlesen()
    Dim strFile As String
    
    
    Dim i As Long
        
 'Opens All Subfolders and lists them in the Activeworksheet

 Dim fldr As FileDialog
 Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
 fldr.Show
 f = fldr.SelectedItems(1)
 f = f & "\"
 ibox = InputBox("File Must Contain (Note * wildcards can be used) ", , "*.xls*")
 On Error GoTo ext
 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)



ext:
    
    
For i = 1 To Rows.Count
    
    strPath = ThisWorkbook.Worksheets(1).Cells(i, 1) '  <--Enter Path here
    strExt = "*.xlsx" ' <-- Enter Data Type you want to open
    
    If strPath = "" Then
        Exit Sub
    Else
        strFile = Dir(strPath & strExt)
        Do While Len(strFile) > 0
            Workbooks.Open Filename:=strPath & strFile ' Opens File
                                
            
                 If BlattExist("Beutel(bag)") Then ' <-- Enter the Worksheet that includes the Data
                 
                        
                        Workbooks(strFile).Worksheets("Beutel(bag)").Range("B73,F73:I73,B90,F90:I90,B91,F91:I91").Copy '<-- Enter Cells that include the Data
                                                      
                         
                         'Shortens Filename if Name exceeds 31 Characters
                             If Len(strFile) > 0 Then
                              If Len(strFile) > 31 Then
                                 strFile = Left(strFile, 31)
                              End If
                             End If
                        
                        
                         MsgBox "Found Data copying will be done"
                        
                        
                        ThisWorkbook.Worksheets.Add.Name = strFile
                        'Fehler Ende
                        ThisWorkbook.Worksheets(strFile).Range("A1").PasteSpecial Paste:=xlValues
                        Application.CutCopyMode = False 'deletes the copy buffer
                        
              
                  Else
                   MsgBox "File doesnt include the wanted Data"
                  End If
                        
                
            Workbooks(strFile).Close False
                  
           strFile = Dir()
       
        Loop

    End If
    Next
End Sub

'Function of checking the existance of a Worksheet
Function BlattExist(strBlatt As String) As Boolean

Dim shDummy

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