AW: Dateinamen auslesen
18.10.2006 17:57:48
fcs
Hallo Robert,
folgendes Makro ermittelt zunächst an Hand des Dateinamens die Datei(en) mit dem altuellsten Datum.
Im nächsten Schritt werden die Dateinamen, die das aktuellste Datum beinhalten, in ein Datenfeld eingelesen.
Im 3. Schritt werden die Daten aus Spalte A der Dateien in das aktuelle Blatt eingelesen.
Das Makro kopierts in ein Modul deiner persönlichen Makrodatei (Diese legt Excel automatisch an, wenn du Makros in dieser Datei aufzeichnest). Die Bezeichnung der Variablen "MeinOrdner" muss du natürlich für deine Dateien anpassen!
Zur Anwendung des Makros aktivierst du das Blatt in dem die Daten eingetragen werden sollen und startest das Makro.
Ich hoffe das Makro entspricht deinen Wünschen.
Gruß
Franz
Sub AktuellsteDatei()
Dim MeinOrdner As String, wbQ As Workbook, wksQ As Worksheet, wksZ As Worksheet
Dim Datum As Date, I As Integer, Dateiname As String, LZeileZ As Long, LZeileQ As Long
Dim Zeile As Long, Dateien() As String, LSpalteZ As Integer
MeinOrdner = "C:\Lokale Daten\Test" 'Name des Ordners mit den Dateien
Set wksZ = ActiveSheet 'Zieltabelle für Daten
'Aktuellstes Datum ermitteln
Dateiname = Dir(MeinOrdner & "\*.xls")
If Dateiname <> "" Then
Datum = 0
Do
If Datum < DateSerial(Val(Mid(Dateiname, 7, 2)) + 2000, Val(Mid(Dateiname, 4, 2)), Val(Mid(Dateiname, 1, 2))) Then
Datum = DateSerial(Val(Mid(Dateiname, 7, 2)) + 2000, Val(Mid(Dateiname, 4, 2)), Val(Mid(Dateiname, 1, 2)))
End If
Dateiname = Dir
Loop Until Dateiname = ""
Else
MsgBox "Keine Dateien gefunden"
Exit Sub
End If
'Aktuellste Dateien in Feld einlesen
I = 0
Dateiname = Dir(MeinOrdner & "\*.xls")
Do
If Datum = DateSerial(Val(Mid(Dateiname, 7, 2)) + 2000, Val(Mid(Dateiname, 4, 2)), Val(Mid(Dateiname, 1, 2))) Then
I = I + 1
ReDim Preserve Dateien(1 To I)
Dateien(I) = Dateiname
End If
Dateiname = Dir
Loop Until Dateiname = ""
'Daten aus aktuellen Dateien einlesen
LZeileZ = 0
'Prüfung ob Daten in Spalte A
If Application.WorksheetFunction.CountA(wksZ.Columns(1)) = 0 Then
LSpalteZ = 1
Else
LSpalteZ = wksZ.Cells(1, wksZ.Columns.Count).End(xlToLeft).Column + 1 'leere Spalte Zieltabelle
End If
For I = 1 To UBound(Dateien)
Set wbQ = Application.Workbooks.Open(Filename:=MeinOrdner & "\" & Dateien(I), ReadOnly:=True)
Set wksQ = wbQ.Sheets(1)
LZeileQ = wksQ.Cells(wksQ.Rows.Count, 1).End(xlUp).Row 'Letzte Zeile Spalte A Quelltabelle
For Zeile = 1 To LZeileQ
LZeileZ = LZeileZ + 1
wksZ.Cells(LZeileZ, LSpalteZ).Value = wksQ.Cells(Zeile, 1).Value
Next
wbQ.Close savechanges:=False
Next
End Sub