VBA - Check Date In File Name & Delete If Over 6 Months Old

[t0ny84]

Hi,

I have written the below code for a previous spreadsheet I built and am hoping someone can assist in how I can change this to allow it to check in a main directory (including any sub directories) for XLSX Files and if older than 6 months and have BACKUP in the name delete (the backup folder and the sub directories SHOULD only have the back up files in there no other files).

The below code currently copies a set sheet from a workbook into a brand new spreadsheet then saves the document in a folder based on the year (2021, 2022, etc. C:\Backup\YEAR FOLDER) using a file name format of "backup_MONTH_dd_mm_yy_ss.xlsx". What I am trying to add on is when the script runs (either by another script or as part of this script) it checks the all XLSX files in the folder BACKUP and any sub folders (e.g. 2021) to see if the date portion of the file name is over 6 months old. If over 6 months then it would either move to a specified folder or delete these backups.

The check I believe is the easiest to use (as already using FileSystemObject) would be something like:

Example
trimmedfilename = Trim(fso.Filename)
If trimmedfilename is less than (trimmeddfilename + 180 (6 months (30x6))) then keep the file.
If over trimmedfilename + 180 (over 6 months old) it would either delete these files or move them into another sub directory called delete.
If I can get the files deleted without user confirmation ok oherwise would move them to that directory (e.g. Over 6 Months Old) and I would manually delete them when needed.

e.g.
get fso filename trimmed
If filename (date) = 6 months old delete else skip
next file name
if ws.filename'

Sub FileBackUp()

Dim srcSheet As Worksheet
Dim NewBook As Workbook
Dim wshape As Shapes
Dim fso As FileSystemObject

Dim FileExtension As String
Dim BackUpFolderLocation As String
Dim BackUpFileName As String
Dim FullBackUpFileName As String
Dim BackUpYearFolder As String
Dim uName As Variant

uName = Environ("USERNAME") * 1
BackUpFolderLocation = "C:\Backup\"
BackUpYearFolder = Format(Date, "yyyy")
BackUpFileName = "backup_" & Format(Now(), "mmmm_dd_mm_yy_ss")
Set srcSheet = Nothing

Set srcWBK = Nothing
Set NewBook = Nothing
Set fso = New FileSystemObject

If fso.FolderExists(BackUpFolderLocation) = False Then
fso.CreateFolder (BackUpFolderLocation)
Else
End If

If fso.FolderExists(BackUpFolderLocation) = True Then

' Part 2 of original copy method
'Set srcSheet = ThisWorkbook.Worksheets("TIL Logger")
'Set NewBook = Workbooks.Add
'srcSheet.Copy After:=NewBook.Sheets(Sheets.Count)
'Application.DisplayAlerts = False

  Set NewBook = Workbooks.Add
    ThisWorkbook.Sheets("TIL Logger").UsedRange.Copy
    ActiveSheet.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats

With NewBook
With .Sheets("Sheet1")
.Rows("1:8").EntireRow.Delete
.Range("M1:N1").Merge
.Range("M1:N1").VerticalAlignment = xlCenter
.Range("M1").Value = "Backed Up"
.Range("M2").Value = "Date:"
.Range("M3").Value = "Time:"
.Range("M4").Value = "Stafflink ID (by)"

.Range("N2").Value = Format(Date, "dd/mm/yyyy")
.Range("N3").Value = Format(Date, "hh:mm AM/PM")
.Range("N4").Value = uName
.SaveAs Filename:=BackUpFolderLocation & BackUpFileName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End With
.Close

End With

End If

End Sub

Please don't hesitate to ask further questions to get a better understanding! and as always thanks in advance!

t0ny84

 

[John_w]

Try this macro, though as a 'safety catch' it doesn't actually delete any files it finds unless you uncomment the thisFile.Delete line. The MsgBox line is informational only, allowing you to check that it finds the correct files to delete, and can be deleted.

Public Sub Delete_Backup_Files()
    Delete_Files_In_Folders "C:\Backup\", 180
End Sub


Private Sub Delete_Files_In_Folders(folderPath As String, daysOld As Long)

    Static FSO As Object
    Dim thisFolder As Object, subfolder As Object
    Dim thisFile As Object
    Dim parts As Variant, fileNameDate As Date
   
    If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
   
    'Delete "backup_MONTH_dd_mm_yy_ss.xlsx" files in this folder older than 'daysOld' days old
   
    Set thisFolder = FSO.GetFolder(folder)
    For Each thisFile In thisFolder.Files
        If UCase(thisFile.Name) Like UCase("BACKUP*.xlsx") Then
            parts = Split(thisFile.Name, "_")
            fileNameDate = DateSerial(parts(4), parts(3), parts(2))
            If Date - fileNameDate >= daysOld Then
                MsgBox thisFile.Path & vbCrLf & "File name date " & fileNameDate & vbCrLf & Date - fileNameDate & " days old", Title:="DELETE FILE"
                'thisFile.Delete   'UNCOMMENT THIS LINE
            End If
        End If
    Next
           
    'Delete files in subfolders
   
    For Each subfolder In thisFolder.SubFolders
        Delete_Files_In_Folders subfolder.Path, daysOld
    Next

End Sub

 

[t0ny84]

Run Time Error 9 - Subscript Out Of Range on

Try this macro, though as a 'safety catch' it doesn't actually delete any files it finds unless you uncomment the thisFile.Delete line. The MsgBox line is informational only, allowing you to check that it finds the correct files to delete, and can be deleted.

Public Sub Delete_Backup_Files()
    Delete_Files_In_Folders "C:\Backup\", 180
End Sub


Private Sub Delete_Files_In_Folders(folderPath As String, daysOld As Long)

    Static FSO As Object
    Dim thisFolder As Object, subfolder As Object
    Dim thisFile As Object
    Dim parts As Variant, fileNameDate As Date
  
    If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
  
    'Delete "backup_MONTH_dd_mm_yy_ss.xlsx" files in this folder older than 'daysOld' days old
  
    Set thisFolder = FSO.GetFolder(folder)
    For Each thisFile In thisFolder.Files
        If UCase(thisFile.Name) Like UCase("BACKUP*.xlsx") Then
            parts = Split(thisFile.Name, "_")
            fileNameDate = DateSerial(parts(4), parts(3), parts(2))
            If Date - fileNameDate >= daysOld Then
                MsgBox thisFile.Path & vbCrLf & "File name date " & fileNameDate & vbCrLf & Date - fileNameDate & " days old", Title:="DELETE FILE"
                'thisFile.Delete   'UNCOMMENT THIS LINE
            End If
        End If
    Next
          
    'Delete files in subfolders
  
    For Each subfolder In thisFolder.SubFolders
        Delete_Files_In_Folders subfolder.Path, daysOld
    Next

End Sub

Hey John,
Thanks for the code, I am getting a run-time error 5 - "Invalid procedure or argument" on "Set thisfolder = fso.getfolder(folder).
Do you know why this might be? I am using Excel 2013.
Thanks again!
t0ny84

 

[t0ny84]

Hey John,

Sorry for the double post, I couldn't update my previous post due to being over 10 minutes.

Update:
Figured the above out - was missing Path in this line of code was folder but should be folderPath.

Now it moves through to the next line of code but hits a run-time error 9 - subscript out of range at filenamedate.
fileNameDate = DateSerial(parts(4), parts(3), parts(2))

 

[John_w]

Yes, the line should be Set thisFolder = FSO.GetFolder(folderPath)

What is the value of thisFile.Name?

 

[t0ny84]

Yes, the line should be Set thisFolder = FSO.GetFolder(folderPath)

What is the value of thisFile.Name?

The value of thisFile.Name is backup_22042020.xlsx (which is one of the test backup files).

 

[t0ny84]

Yes, the line should be Set thisFolder = FSO.GetFolder(folderPath)

What is the value of thisFile.Name?

Thank you so much for your assistance in trying to get this to work for me. Since asking the question I came across two macros which I think might actually work better than what I was after \ wanted.
They are working by checking the file creation date and using this date to go off, I think this method will be better than using the date entered as part of the backup name as it means that any file which is in the folder if older than a certain time (or count) can be deleted.

If I might ask one question of you John_w: Do you know how I could use either of the two macros below to check the file type is XLSX?
Thanks again so much for your help and assistance!

Sub DeleteBackups()

Dim fso As Object
Dim fcount As Object
Dim collection As New collection
Dim obj As Variant
Dim i As Long

Set fso = CreateObject("Scripting.FileSystemObject")
'https://stackoverflow.com/questions/27550992/excel-vba-leave-5-newest-backups-and-delete-the-rest
'add each file to a collection
For Each fcount In fso.GetFolder("C:\Users\60139173\Desktop\Impact 360\G&D & Q&A Sessions\2021\").Files

    collection.Add fcount

Next fcount

'sort the collection descending using the CreatedDate
Set collection = SortCollectionDesc(collection)

'kill items from index 6 onwards
For i = 10 To collection.Count
    Kill collection(i)
Next i

End Sub

Function SortCollectionDesc(collection As collection)
'https://stackoverflow.com/questions/27550992/excel-vba-leave-5-newest-backups-and-delete-the-rest
'Sort collection descending by datecreated using standard bubble sort
Dim coll As New collection

Set coll = collection
    Dim i As Long, j As Long
    Dim vTemp As Object


    'Two loops to bubble sort
   For i = 1 To coll.Count - 1
        For j = i + 1 To coll.Count
            If coll(i).datecreated < coll(j).datecreated Then
                'store the lesser item
               Set vTemp = coll(j)
                'remove the lesser item
               coll.Remove j
                're-add the lesser item before the greater Item
               coll.Add Item:=vTemp, before:=i
               Set vTemp = Nothing
            End If
        Next j
    Next i

Set SortCollectionDesc = coll

End Function

Sub DeleteOldFiles()
'https://stackoverflow.com/questions/27550992/excel-vba-leave-5-newest-backups-and-delete-the-rest
    Dim fso As New FileSystemObject
    Dim fil As File
    Dim oldfile As File
    Dim BackUpPath As String 'This is the FOLDER where your backups are stored
BackUpPath = "C:\Users\60139173\Desktop\Impact 360\G&D & Q&A Sessions\2021\"

    Do Until fso.GetFolder(BackUpPath).Files.Count < 2
        For Each fil In fso.GetFolder(BackUpPath).Files
            'Checks to see if this file is older than the oldest file thus far
            If oldfile Is Nothing Then Set oldfile = fil
            If oldfile.DateLastModified > fil.DateLastModified Then Set oldfile = fil
        Next fil
        fso.DeleteFile oldfile, True
        Set oldfile = Nothing
    Loop

End Sub

 

[John_w]

The value of thisFile.Name is backup_22042020.xlsx

So not the format you said in the OP - that's why the DateSerial call fails.

check the file type is XLSX?

Similar to the If ... Like .... statement I used:

If UCase(fil.Name) Like UCase("*.xlsx") Then

for the second macro and replace fil with fcount for the first macro.

 

[t0ny84]

So not the format you said in the OP - that's why the DateSerial call fails.


Similar to the If ... Like .... statement I used:

If UCase(fil.Name) Like UCase("*.xlsx") Then

for the second macro and replace fil with fcount for the first macro.

Hey John,

"So not the format you said in the OP - that's why the DateSerial call fails." <- You would be surprised how many times I looked at this and also at the original post and thought I had them matched! ??

I really cannot thank you (and everyone else who has helped me on here)!
t0ny84