Sub Ordner_suchen()
Dim dat
Dim ordner
Dim datein
Dim fso
Dim arr(65536, 2)
Dim L As Long
Dim Z As Long
Dim WB
Dim dsplalert As Boolean
Dim cal
Dim scrup As Boolean
Dim ev As Boolean
With Application
dsplalert = .DisplayAlerts
cal = .Calculation
scrup = .ScreenUpdating
ev = .EnableEvents
.DisplayAlerts = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
arr(L, 0) = "Nr."
arr(L, 1) = "Druck [bar(g)]"
arr(L, 2) = "Temperatur [?C]"
L = L + 1
Set dat = Application.FileDialog(msoFileDialogFolderPicker)
With dat
.Title = "Such sch?n...."
.InitialFileName = "C:\"
nochmal:
If .Show = -1 Then
ordner = .SelectedItems(1)
Else:
If MsgBox("Ordner ausw?hlen vergessen." & vbCrLf & "Nochmal ?", vbYesNo) = vbYes Then
GoTo nochmal
Else:
GoTo raus
End If
End If
End With
Set fso = CreateObject("Scripting.filesystemobject")
Set datein = fso.getfolder(ordner)
For Each WB In datein.Files
If WB.Name Like "*.xlsx" Then
Workbooks.Open WB
For Z = 1 To Sheets(1).Range("a1").End(xlUp).Row
arr(L, 1) = Sheets(1).Cells(13, 2).Text
arr(L, 2) = Sheets(1).Cells(12, 2).Text
L = L + 1
Next
Workbooks(WB.Name).Close False
End If
Next
Range("A:C") = arr
raus:
With Application
.DisplayAlerts = dsplalert
.Calculation = cal
.ScreenUpdating = scrup
.EnableEvents = ev
End With
End Sub