ich möchte alle Dateien (*.csv) aus einem Verzeichnis verschieben. Lediglich die neueste Datei soll im Ordner verbleiben.
Danke und Gruß
demo
Option Explicit
Sub Dateien()
Dim FSO, F, Datei, MMax As Date, Pfad1 As String, Ext As String, Pfad2 As String, NamAlt As String
On Error GoTo Fehler
'****
Pfad1 = "X:\Temp\" 'Von
Pfad2 = "X:\Temp\Test\" 'Nach
Ext = "csv"
'****
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each Datei In FSO.getFolder(Pfad1).Files
If LCase(FSO.GetExtensionName(Datei)) = LCase(Ext) Then
Set F = FSO.getfile(Datei)
If NamAlt = "" Then 'im ersten Durchlauf
MMax = F.DateCreated
NamAlt = Datei
Else
If F.DateCreated > MMax Then
'nächse Datei ist neuer
FSO.MoveFile NamAlt, Pfad2 'Ältere verschieben
MMax = F.DateCreated
NamAlt = Datei
Else
'Diese Ältere verschieben
FSO.MoveFile Datei, Pfad2 '
End If
End If
End If
Next
Err.Clear
Fehler:
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & vbLf & Err.Description: Err.Clear
End Sub
Option Explicit
Sub Dateien()
Dim FSO, F, Datei, MMax As Date, Pfad1 As String, Ext As String
Dim Pfad2 As String, NamAlt As String, DDatum
On Error GoTo Fehler
'****
Pfad1 = "X:\Temp\" 'Von
Pfad2 = "X:\Temp\Test\" 'Nach
Ext = "csv"
'****
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each Datei In FSO.getFolder(Pfad1).Files
If LCase(FSO.GetExtensionName(Datei)) = LCase(Ext) Then
DDatum = Left(Right(Datei, 14), 10)
If Not IsDate(DDatum) Then
MsgBox "Diese csv-Datei entspricht NICHT der Namens-Konvention" & vbLf & vbLf & _
Dir(Datei)
Exit Sub
End If
If NamAlt = "" Then 'im ersten Durchlauf
MMax = DDatum
NamAlt = Datei
Else
If DDatum > MMax Then
'Datei ist neuer
FSO.MoveFile NamAlt, Pfad2 'Ältere verschieben
MMax = DDatum
NamAlt = Datei
Else
'Diese Ältere verschieben
FSO.MoveFile Datei, Pfad2 '
End If
End If
End If
Next
Err.Clear
Fehler:
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & vbLf & Err.Description: Err.Clear
End Sub