Sub Mehrere_Dateien_einlesen()
Dim strFile As String
Dim i As Long
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)
strExt = "*.xlsx"
If strPath = "" Then
Exit Sub
Else
strFile = Dir(strPath & strExt)
Do While Len(strFile) > 0
Workbooks.Open Filename:=strPath & strFile
If BlattExist("Beutel(bag)") Then
Workbooks(strFile).Worksheets("Beutel(bag)").Range("B73,F73:I73,B90,F90:I90,B91,F91:I91").Copy
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
ThisWorkbook.Worksheets(strFile).Range("A1").PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Else
MsgBox "File doesnt include the wanted Data"
End If
Workbooks(strFile).Close False
strFile = Dir()
Loop
End If
Next
End Sub
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