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 = "*.xls*"
On Error resume next
sn = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & f & ibox & """ /s /a /b").stdout.readall, vbCrLf)
on error goto 0
For i = 0 To ubound(sn)-1
strFile = sn(i)
with Workbooks.Open(Filename:=strFile)
If BlattExist(.sheets(1).parent, "Beutel(bag)") Then
.Worksheets("Beutel(bag)").Range("B73,F73:I73,B90,F90:I90,B91,F91:I91").Copy
sBlattName = left(dir(strFile), 31)
MsgBox "Found Data copying will be done"
ThisWorkbook.Worksheets.Add().Name = sBlattName
ThisWorkbook.Worksheets(sBlattName).Range("A1").PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Else
MsgBox "File doesnt include Worksheet ""Beutel(bag)"""
End If
.close False
next
End Sub
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