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