Daten sammeln

Sub Aus_allen()
Dim strDatei As String, strPfad As String, strTyp As String
Dim wbX As Workbook, wksX As Worksheet, wksN As Worksheet
Dim lngCount As Long
Application.ScreenUpdating = False
strPfad = "C:\test"                 'Pfad anpassen
strTyp = "xlsm"                      'Dareityp anpassen
Set wksN = ThisWorkbook.Sheets(4)   'Zieltabelle
lngCount = 2                        'Startzeile in der Zieltabelle
wksN.Range(wksN.Rows(lngCount), wksN.Rows(wksN.UsedRange.Rows.Count + lngCount)).Delete
strDatei = Dir(strPfad & "\*." & strTyp)
Do Until strDatei = ""
Set wbX = Workbooks.Open(strPfad & "\" & strDatei)
Set wksX = wbX.Sheets(5)
wksN.Cells(lngCount, 3) = wksX.Cells(2, 3)
wksN.Cells(lngCount, 4) = wksX.Cells(1, 3)
wksN.Cells(lngCount, 5) = wksX.Cells(2, 4)
lngCount = lngCount + 1
wbX.Close False
strDatei = Dir
Loop
Application.ScreenUpdating = True
End Sub