Dateien mit gleichem Änderungsdatum löschen.
21.03.2019 08:31:24
Marco
heute bräuchte ich einmal Eure Hilfe. Es geht darum, dass ich täglich automatische Backups mehrere Dateien mache. Die Dateien werden jeweils mit aktuellem Datum im Dateinamen gespeichert.
Meine Iddee ist jetzt um Speicherplatz zu sparen einmal wöchendlich ein Script laufen zu lassen, dass doppelte Dateien (also mit identischem Änderungsdatum) aussortiert.
Im ersten Step denke ich das Verzeichnis auszulesen einschliesslich des Attributes des Änderungsdatums. Diese werden in eine Tabelle geschrieben.
Mit RemoveDuplicates kann ich zwar die Einträge in der Tabelle löschen, aber wie nutze ich dieses um andere Aktionen (Wie in meinem Fall Kill) auszuführen?
Oder gibt es einen besseren Ansatzweg?
Anbei die Code-Schnippsel die ich momentan als Ausgangspunkt habe.
VG
Marco
Sub Dateienauslesen()
Dim s_Dateiname As String
Dim i As Integer
Dim fs As FileSystemObject
Dim f As Object
i = 1
Cells(i, 1).Value = "Dateiname"
Cells(i, 2).Value = "Letzte ÄÄnderung"
Cells(i, 3).Value = "Erstellungsdatum"
Cells(i, 4).Value = "Letzter Zugriff"
Cells(i, 5).Value = "Größe"
Cells(i, 6).Value = "Typ"
Range(Cells(i, 1), Cells(i, 6)).Font.Bold = True
On Error GoTo Ende:
ChDir "H:\My Documents\"
s_Dateiname = Dir$("H:\My Documents\*.*")
Do While s_Dateiname ""
i = i + 1
Cells(i, 1).Value = s_Dateiname
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(s_Dateiname)
Cells(i, 2).Value = f.DateLastModified
Cells(i, 3).Value = f.DateCreated
Cells(i, 4).Value = f.DateLastAccessed
Cells(i, 5).Value = f.Size
Cells(i, 6).Value = f.Type
s_Dateiname = Dir$()
Loop
ActiveSheet.Columns("A:F").AutoFit
Exit Sub
Ende:
MsgBox "Das angegebene Verzeichnis existiert nicht!", vbCritical
End Sub
Sub DateiEigenchaften()
Worksheets("Tabelle1").Activate
For rw = 1 To 30
On Error Resume Next
Cells(rw, 1) = ActiveWorkbook.BuiltinDocumentProperties(rw).Name
Cells(rw, 2) = ActiveWorkbook.BuiltinDocumentProperties(rw).Value
Next
End Sub
Sub Dupliate_entfernen()
ActiveSheet.Range("$B$1:$B$16").RemoveDuplicates Columns:=1, Header:=xlYes
End Sub