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
End With
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