VBA Dateien löschen

Hallo zusammen
Folgende Speicherung wir bei mir täglich mehrmals ausgeführt
ActiveWorkbook.SaveAs "D:\users\Sun\Connect\Ablage\" & Month(Now) & "." & (Year(Now) & " LfdNr." & _
Range("I2").Value & ".XLS")
.
Ich habe nun Irgendwann den Ordner voll mit Dateien.
Es werden jedoch nur die letzten abgespeicherten Dateien eines Monats gebraucht.
d.h. ich benötige einen Zusatz das wenn ein neuer Monat beginnt alle Dateien des Vormonates, gelöscht werden außer die zuletzt gespeicherte bzw. die mit der größten fortlaufenden Nr.
Falls dies hilft: ( Unter I2 werden fortlaufende Nummern vergeben; die letzte Nr. entspricht auch der letzten Datei eines Monates)
Grüße Stefan
Reutlingen Schöner Sonnenuntergang; Warm

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Stefan!
Ungetestet! Achtung, die Dateien sind entgültig weg! also zuerst mit kopien testen!

Sub Loeschen()
Dim objFS As FileSearch
Dim strPath As String, strFile As String
Dim intIndex As Integer, intC As Integer
Dim lngN As Long
Dim objFSO As Object, objFile As Object
Dim vFiles() As Variant, vNum() As Variant

strPath = "F:\Temp" '"D:\users\Sun\Connect\Ablage"

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFS = Application.FileSearch

With objFS
  .NewSearch
  .LookIn = strPath
  .FileType = msoFileTypeExcelWorkbooks
  .SearchSubFolders = False

  If .Execute > 0 Then

    For intIndex = 1 To .FoundFiles.Count

      Set objFile = objFSO.GetFile(.FoundFiles(intIndex))

      If DateSerial(Year(objFile.DateCreated), Month(objFile.DateCreated), 1) = _
        DateSerial(Year(Date), Month(Date) - 1, 1) Then

        strFile = objFSO.GetBaseName(.FoundFiles(intIndex))
        lngN = Clng(Mid(strFile, InStr(1, strFile, "_") + 1))
        Redim Preserve vFiles(intC)
        Redim Preserve vNum(intC)
        vFiles(intC) = .FoundFiles(intIndex)
        vNum(intC) = lngN
        intC = intC + 1

      ElseIf objFile.DateCreated <= DateSerial(Year(Date), Month(Date) - 1, 0) Then

        objFSO.DeleteFile .FoundFiles(intIndex), True

      End If

    Next

  End If

End With

If intC > 0 Then
  For intIndex = 0 To UBound(vFiles)
    If vNum(intIndex) < Application.Max(vNum) Then
      objFSO.DeleteFile vFiles(intIndex), True
    End If
  Next
End If

Set objFS = Nothing
Set objFSO = Nothing

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread