Option Explicit
Sub Feedback()
On Error GoTo Fehler
Dim Pfad As String, Datei As String, Ext As String, Zeile As Long
Dim TBM As Worksheet, TBx As Workbook, Blatt
Dim RNG1 As Range, RNG2 As Range
Set TBM = ThisWorkbook.Sheets("Tabelle1")
Pfad = "X:\temp\Feedback\"
Ext = "*.xlsx"
Zeile = 2
With TBM
.UsedRange.ClearContents
Datei = Dir(Pfad & Ext)
Do While Len(Datei) > 0
Set TBx = Workbooks.Open(Filename:=Pfad & Datei)
For Each Blatt In TBx.Worksheets
Select Case Blatt.Name
Case "Arbeit", "Kosten", "Lager", "Zeit", "Data"
Case Else
.Cells(Zeile, 2).Resize(12, 1) = Blatt.Range("C4")
.Cells(Zeile, 3).Resize(12, 4).Value = Blatt.Range("M10:P21").Value
Zeile = Zeile + 12
End Select
Next
TBx.Close False
Datei = Dir()
Loop
End With
Err.Clear
Fehler:
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & vbLf & Err.Description: Err.Clear
End Sub