delete files based on age in vba

I want to delete files that are more than  two years old.  The file name is PSBWIRE20110228.xlsm.   Date stamp was inserted on save with the "yyyymmdd" format.
The two years could be based on the year or number of days.  The deletion time is arbitrary and the code should allow me to easily change duration of time of deletion.  THX rgds/ron
1r3o2n8Asked:
Who is Participating?

[Webinar] Streamline your web hosting managementRegister Today

x
 
Christian de BellefeuilleConnect With a Mentor ProgrammerCommented:
Here's your code...
I'm not sure if the date format will be correct for every countries, so you might have change that line where i assign dDate to have a valid format.

Public Sub DeleteOldFiles()
    Dim aFile
    Dim sPath As String
    Dim sDate As String
    Dim dDate As Date
    Dim dLimit As Date
    
    sPath = "C:\TEMP"
    aFile = Dir(sPath & "\*.xlsm")
    While aFile <> ""
        sDate = Mid(aFile, 8, 8)
        dDate = Left(sDate, 4) & "-" & Mid(sDate, 5, 2) & "-" & Right(sDate, 2)
        
        ' Change your duration here.  Y for Year
        dLimit = DateAdd("yyyy", -2, Now)
        
        If dDate < dLimit Then
            Kill sPath & "\" & aFile
        End If
        
        aFile = Dir
    Wend
End Sub

Open in new window

1
 
SiddharthRoutCommented:
Is this what you want? Before you run it on a folder, make a backup of that folder as this code will delete the files which matches the criteria.

Const FilesPath As String = "C:\Temp\"

Sub Sample()
    Dim Ret As String, strCurrentFile As String
    
    Ret = MsgBox("Would you like to enter number of Years or Number of Days as deletion criteria?" & vbCrLf & _
    "Press 'Yes' for Years and 'No' for Days", vbYesNoCancel, "Deleteion Criteria")
    
    Select Case Ret
    
    Case vbYes
        Ret = InputBox("Please enter number of years", "Number of Years")
        
        strCurrentFile = Dir(FilesPath & "*.*")
        Do While strCurrentFile <> ""
            If Year(Now) - Year(FileLastModified(FilesPath & strCurrentFile)) > Ret - 1 Then
                Kill (FilesPath & strCurrentFile)
            End If
            strCurrentFile = Dir
        Loop
    Case vbNo
        Ret = InputBox("Please enter number of Days", "Number of Days")
        
        strCurrentFile = Dir(FilesPath & "*.*")
        Do While strCurrentFile <> ""
            If DateDiff("D", FileLastModified(FilesPath & strCurrentFile), Now) > Ret - 1 Then
                Kill (FilesPath & strCurrentFile)
            End If
            strCurrentFile = Dir
        Loop
    Case Else
        Exit Sub
    End Select
End Sub

Function FileLastModified(strFullFileName As String)
    Dim fs As Object, f As Object

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFile(strFullFileName)

    FileLastModified = f.DateLastModified

    Set fs = Nothing: Set f = Nothing
End Function

Open in new window


Sid
0
 
SiddharthRoutConnect With a Mentor Commented:
In fact use this. I have commented the code and I have introduced Debug.Print so that you can check what files match the criteria. If the result is as expected then uncomment the line "Kill"

Sid

'~~> Change the path of the folder here
Const FilesPath As String = "C:\Temp\"

Sub Sample()
    Dim Ret As String, strCurrentFile As String
    
    Ret = MsgBox("Would you like to enter number of Years or Number of Days as deletion criteria?" & vbCrLf & _
    "Press 'Yes' for Years and 'No' for Days", vbYesNoCancel, "Deleteion Criteria")
    
    Select Case Ret
    
    '~~> For number of Years
    Case vbYes
        Ret = InputBox("Please enter number of years", "Number of Years")
        
        strCurrentFile = Dir(FilesPath & "*.*")
        Do While strCurrentFile <> ""
            If Year(Now) - Year(FileLastModified(FilesPath & strCurrentFile)) > Ret - 1 Then
                Debug.Print FilesPath & strCurrentFile
                'Kill (FilesPath & strCurrentFile)
            End If
            strCurrentFile = Dir
        Loop
    '~~> For number of Days
    Case vbNo
        Ret = InputBox("Please enter number of Days", "Number of Days")
        
        strCurrentFile = Dir(FilesPath & "*.*")
        Do While strCurrentFile <> ""
            If DateDiff("D", FileLastModified(FilesPath & strCurrentFile), Now) > Ret - 1 Then
                Debug.Print FilesPath & strCurrentFile
                'Kill (FilesPath & strCurrentFile)
            End If
            strCurrentFile = Dir
        Loop
    End Select
End Sub

'~~> Gets the Last saved/Modified Date of a file
Function FileLastModified(strFullFileName As String)
    Dim fs As Object, f As Object

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFile(strFullFileName)

    FileLastModified = f.DateLastModified

    Set fs = Nothing: Set f = Nothing
End Function

Open in new window

0
Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
Christian de BellefeuilleProgrammerCommented:
Oops sorry, didn't noticed that someone answered.

Well the big difference between our versions is that Sid's version check for the real time stamp (the last modification), and mine is based on the time stamp that you have placed in the file name.  

i've not analysed Sid version throughfuly but it should work too
0
 
sdwalkerConnect With a Mentor Commented:
I understood you to want the date check to occur on the filename rather than the last time it was modified, so I've modified Siddarth's code to use this instead.

I agree with Siddarth ... good idea to verify that the files you want deleted are listed in the immediate window (Debug.print statements) before running the code.  There's no undoing it here.

Good luck,

sdwalker
'~~> Change the path of the folder here
Const FilesPath As String = "C:\Temp\"

Sub test()

    Ret = MsgBox("Would you like to enter number of Years or Number of Days as deletion criteria?" & vbCrLf & _
    "Press 'Yes' for Years and 'No' for Days", vbYesNoCancel, "Deleteion Criteria")
    
    Select Case Ret
    
    '~~> For number of Years
    Case vbYes
        numYrs = InputBox("Please enter number of years", "Number of Years")
        myKeepDate = DateAdd("d", -numYrs, Date)
        
    '~~> For number of Days
    Case vbNo
        numDays = InputBox("Please enter number of Days", "Number of Days")
        myKeepDate = DateAdd("d", -numDays, Date)
        
    End Select
  strCurrentFile = Dir(FilesPath & "*.xlsm")
    
  Do While strCurrentFile <> ""
  
    'Assuming date always shows up right after PSBWIRE and always of yyyymmdd format
    
    If InStr(1, strCurrentFile, "PSBWIRE") Then
      strDate = Mid(strCurrentFile, 8, 8)
      
      varDate = CDate(Mid(strDate, 5, 2) & "/" & Right(strDate, 2) & "/" & Left(strDate, 4))
    
      If varDate < myKeepDate Then
    
        Debug.Print FilesPath & strCurrentFile
        'Kill (FilesPath & strCurrentFile)
        
      End If
      
    End If
    
    strCurrentFile = Dir
    
  Loop


End Sub

Open in new window

0
 
Christian de BellefeuilleProgrammerCommented:
One little comment about my solution, we should change line 9 for this:
    aFile = Dir(sPath & "\PSBWIRE*.xlsm")

Also, the date format that i use here is yyyy-mm-dd.  So if you use a different date format, you might have to change line 12 for something more appropriate like this (if you use dd/mm/yyyy)
     dDate = Right(sDate, 2) &  "/" & Mid(sDate, 5, 2) & "/" & Left(sDate, 4)
0
 
1r3o2n8Author Commented:
All solutions were good, but cdebel was btrief and concise, so he/she got more points.  Thanks to all who responed quickly
0
All Courses

From novice to tech pro — start learning today.