Zusammenfassen von Daten aus mehreren xlsx

Hallo,

ich habe Dateien die jeden Tag unter dem jeweiligem Datum abgespeichert werden.

Nun möchte ich eine Datei erstellen die die Information aus den letzten 5 gespeicherten Dateien rauszieht und in der neuen Datei wiedergibt.

Leider sind die Dateien ttmmjjjj benannt somit ist die Aufzählung nicht so einfach.

Gibt es eine Möglichkeit so etwas zu machen und wenn ja wie würde dann der Makro dafür aussehen.

Vielen Dank für die Hilfe

Hallo Polyton,

ein entsprechendes Makro sieht etwa wie folgt aus.

Das Makro richtest du in einer Musterdatei ein, in der jeweils die Daten eingelesen werden sollen.

Gruß
Franz

Sub Infos\_letzte\_5\_Tage()
 Dim strPfad As String, strDatei As String
 Dim wbkNeu As Workbook, wksNeu As Worksheet
 Dim wbkTag As Workbook, wksTag As Worksheet
 Dim ZeileNeu As Long, intCount As Integer, datDatum As Date
 Dim strDateien() As String
 strPfad = "C:\Users\Public\Test\Tage" 'Verzeichnis mit den Dateien

 Set wbkNeu = ActiveWorkbook
 Set wksNeu = wbkNeu.Worksheets(1)

 datDatum = Date
 'Namen der Tages-Dateien in ein Datenfeld einlesen
 Do Until intCount = 5 Or datDatum = Date - 10
 datDatum = datDatum - 1
 strDatei = Format(datDatum, "DDMMYYYY") & ".xlsx"
 If Dir(strPfad & "\" & strDatei) "" Then
 intCount = intCount + 1
 ReDim Preserve strDateien(1 To intCount)
 strDateien(intCount) = strPfad & "\" & strDatei
 End If
 Loop
 ZeileNeu = 3 'Zeile unterhalb der die Daten eingetragen werden sollen
 If intCount \> 0 Then
 With Application
 .EnableEvents = False
 .ScreenUpdating = False
 .Calculation = xlCalculationManual
 End With
 'Daten aus den Tagesdateien einlesen
 For intCount = intCount To 1 Step -1
 'tagesdatei schreibgeschützt öffen
 Set wbkTag = Workbooks.Open(Filename:=strDateien(intCount), ReadOnly:=True)
 'Tabellenblatt mit Tagesdaten setzen
 Set wksTag = wbkTag.Worksheets(1)
 'Zielzeile setzen
 ZeileNeu = ZeileNeu + 1
 'Daten übertragen
 With wksNeu
 .Cells(ZeileNeu, 1) = wbkTag.Name
 .Cells(ZeileNeu, 2) = wksTag.Range("A1")
 .Cells(ZeileNeu, 3) = wksTag.Range("A3")
 .Cells(ZeileNeu, 4) = wksTag.Range("B3")
 End With
 'Datei mit Tagesdaten wieder schliessen
 wbkTag.Close savechanges:=False
 Next
 With Application
 .EnableEvents = True
 .ScreenUpdating = True
 .Calculation = xlCalculationAutomatic
 End With
 Else
 MsgBox "keine Dateien gefunden"
 End If
End Sub

Super Vielen Dank,

werds gleich mal ausprobieren.