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.