Best Way to automatically delete backup files using vba

[komobu]

I have a pretty crucial file that I use often. Every time I close, I have a vba module that adds a date/ time to the filename and backs up the file to 2 different locations and then saves the file to My Documents. If I use the file 5 times in day, five backups are created for the day. In a given month, there might be 50 to 150 backups added to these two directories. So what I am wondering about is how to create an Automatic Deletion for these files. I am thinking maybe delete every file over a year old, but what I would really like is to delete all the files in a given month except the newest for the given month. For example, I close excel today and my two backups are created. Then it looks at the directory and sees 75 files from Feb 2024. Then it leaves the newest file that was created in feb 2024, but deletes the other 74 older files from that month. This way I could have one back up for each month going several years back.
Any thoughts on how to set this up?
Thanks for any help

 

[HighAndWilder]

I have a pretty crucial file that I use often. Every time I close, I have a vba module that adds a date/ time to the filename and backs up the file to 2 different locations and then saves the file to My Documents. If I use the file 5 times in day, five backups are created for the day. In a given month, there might be 50 to 150 backups added to these two directories. So what I am wondering about is how to create an Automatic Deletion for these files. I am thinking maybe delete every file over a year old, but what I would really like is to delete all the files in a given month except the newest for the given month. For example, I close excel today and my two backups are created. Then it looks at the directory and sees 75 files from Feb 2024. Then it leaves the newest file that was created in feb 2024, but deletes the other 74 older files from that month. This way I could have one back up for each month going several years back.
Any thoughts on how to set this up?
Thanks for any help

What exactly is the file naming convention for the date and time?

How is the backup routine triggered when you close Excel?

 

[komobu]

Good Morning;

The file itself is called Data.xls.

its done as a BeforeSave module.

Then the code looks like this:
ActiveWorkbook.SaveCopyAs ("C:\Users\user\OneDrive\Docs\data" & Format(Now(), "DD MMM YYYY hhmmss") & ".xlsm")

so the backup would be called Data 28 Feb 2025 105105.xlsm

 

[HighAndWilder]

Good Morning;

The file itself is called Data.xls.

its done as a BeforeSave module.

Then the code looks like this:
ActiveWorkbook.SaveCopyAs ("C:\Users\user\OneDrive\Docs\data" & Format(Now(), "DD MMM YYYY hhmmss") & ".xlsm")

so the backup would be called Data 28 Feb 2025 105105.xlsm

This will save a copy of the workbook file in two folders and when the month changes all of the files from the previous month will be deleted apart from the latest one.

You can test it by changing the value of the intMonth and intYear variables.

Follow the instructions in the code.

Start off with empty folders to test it.

This code goes in the ThisWorkbook code module.

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim strExt As String
Dim strFolder1 As String
Dim strFolder2 As String
Dim dteDate As Date
Dim intMonth As Integer
Dim intYear As Integer
Dim lngCount As Long
Dim dteEarliest As Date
Dim strLatest As String
Dim strExtensions As String

  intMonth = Month(Date)
  
  intYear = Year(Date)

  ' The following two lines are for testing purposes only.
  ' The month and year below will be used to format the file name.
  ' If these are commented out then the current month and year will be used.
  
  intMonth = 1 ' **** Comment out this line when you go live. ****
  intYear = 2025 ' **** Comment out this line when you go live. ****
  
  strFolder1 = "C:\Private\Backup1\" ' **** Specify folder one here. Include last '\'. ****
  
  strFolder2 = "C:\Private\Backup2\" ' **** Specify folder two here. Include last '\'. ****
  
  dteDate = DateSerial(intYear, intMonth - 1, 1)
  
  strExtensions = "xlsm,xlsx,xls"

  ' Delete files from Folder 1 for the previous month apart from the latest file.
  If fncGetCountOfFilesForMonthAndYear(strFolder1, strExtensions, Format(dteDate, "MMM YYYY")) > 0 Then
    
    dteEarliest = fncGetEarliestFile(strFolder1, strExtensions)
      
    strLatest = fncGetLatestFileForMonthAndYear(strFolder1, strExtensions, intMonth - 1, intYear, dteEarliest)
      
    Call subDeleteFilesForMonthAndYear(strFolder1, strExtensions, Format(dteDate, "MMM YYYY"), strLatest)
  
  End If
  
  ' Delete files from Folder 2 for the previous month apart from the latest file.
  If fncGetCountOfFilesForMonthAndYear(strFolder2, strExtensions, Format(dteDate, "MMM YYYY")) > 0 Then
    
    dteEarliest = fncGetEarliestFile(strFolder2, strExtensions)
      
    strLatest = fncGetLatestFileForMonthAndYear(strFolder2, strExtensions, intMonth - 1, intYear, dteEarliest)
      
    Call subDeleteFilesForMonthAndYear(strFolder2, strExtensions, Format(dteDate, "MMM YYYY"), strLatest)
  
  End If
      
  dteDate = DateSerial(intYear, intMonth, 1) + TimeSerial(Hour(Time$), Minute(Time$), Second(Time$))
    
  With ActiveWorkbook
    
    strExt = Trim(Mid(.Name, InStrRev(.Name, ".", , vbTextCompare) + 1, 6))
     
    .SaveCopyAs strFolder1 & Replace(.Name, "." & strExt, "", 1) & "-" & Format(dteDate, "DD MMM YYYY hhmmss") & "." & strExt
      
    .SaveCopyAs strFolder2 & Replace(.Name, "." & strExt, "", 1) & "-" & Format(dteDate, "DD MMM YYYY hhmmss") & "." & strExt
    
  End With
    
End Sub

Public Function fncGetCountOfFilesForMonthAndYear(strFolder As String, _
  strExtensions As String, _
  strIncludes As String) As Long
Dim MyFSO As FileSystemObject
Dim MyFile As file
Dim MyFolder As Folder
Dim lngCount As Long

  Set MyFSO = New Scripting.FileSystemObject
  
  Set MyFolder = MyFSO.GetFolder(strFolder)
    
  For Each MyFile In MyFolder.Files
      
    If InStr(1, strExtensions, MyFSO.GetExtensionName(MyFile), vbTextCompare) > 0 And _
      InStr(1, MyFile.Name, strIncludes, vbTextCompare) > 0 Then
      
      lngCount = lngCount + 1
    
    End If
  
  Next MyFile
  
  fncGetCountOfFilesForMonthAndYear = lngCount
    
End Function

Public Function fncGetEarliestFile(strFolder As String, strExtensions As String) As Date
Dim MyFSO As FileSystemObject
Dim MyFile As file
Dim MyFolder As Folder
Dim strEarliest As String
Dim dteDate As Date

  dteDate = Now()

  Set MyFSO = New Scripting.FileSystemObject
  
  Set MyFolder = MyFSO.GetFolder(strFolder)
    
  For Each MyFile In MyFolder.Files
      
    If InStr(1, strExtensions, MyFSO.GetExtensionName(MyFile), vbTextCompare) > 0 Then
        
      If MyFile.DateCreated < dteDate Then
        strEarliest = MyFile.Name
        dteDate = MyFile.DateCreated
      End If
    
    End If
  
  Next MyFile
    
  fncGetEarliestFile = dteDate    ' strEarliest
    
End Function

Public Function subDeleteFilesForMonthAndYear(strFolder As String, _
  strExtensions As String, _
  strIncludes As String, _
  strLatest As String)
Dim MyFSO As FileSystemObject
Dim MyFile As file
Dim MyFolder As Folder
Dim lngCount As Long

  Set MyFSO = New Scripting.FileSystemObject
  
  Set MyFolder = MyFSO.GetFolder(strFolder)
    
  For Each MyFile In MyFolder.Files
      
    If InStr(1, strExtensions, MyFSO.GetExtensionName(MyFile), vbTextCompare) > 0 And _
      InStr(1, MyFile.Name, strIncludes, vbTextCompare) > 0 And _
      MyFile.Name <> strLatest Then
            
      On Error Resume Next
      Kill (strFolder & MyFile.Name)
      On Error GoTo 0
      
      lngCount = lngCount + 1
    
    End If
  
  Next MyFile
      
End Function

Public Function fncGetLatestFileForMonthAndYear(strFolder As String, _
  strExtensions As String, _
  intMonth As Integer, _
  intYear As Integer, _
  dteEarliest As Date)
Dim MyFSO As FileSystemObject
Dim MyFile As file
Dim MyFolder As Folder
Dim strFileExt As String
Dim strLatest As String
Dim dteDate As Date

  Set MyFSO = New Scripting.FileSystemObject
  
  Set MyFolder = MyFSO.GetFolder(strFolder)
    
  For Each MyFile In MyFolder.Files
      
    If InStr(1, strExtensions, MyFSO.GetExtensionName(MyFile), vbTextCompare) > 0 And _
      InStr(1, MyFile.Name, Format(DateSerial(intYear, intMonth, 1), "MMM YYYY"), vbTextCompare) > 0 Then
        
      If MyFile.DateCreated > dteEarliest Then
        strLatest = MyFile.Name
        dteDate = MyFile.DateCreated
      End If
    
    End If
  
  Next MyFile
  
  fncGetLatestFileForMonthAndYear = strLatest
    
End Function

 

[komobu]

This will save a copy of the workbook file in two folders and when the month changes all of the files from the previous month will be deleted apart from the latest one.

You can test it by changing the value of the intMonth and intYear variables.

Follow the instructions in the code.

Start off with empty folders to test it.

This code goes in the ThisWorkbook code module.

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim strExt As String
Dim strFolder1 As String
Dim strFolder2 As String
Dim dteDate As Date
Dim intMonth As Integer
Dim intYear As Integer
Dim lngCount As Long
Dim dteEarliest As Date
Dim strLatest As String
Dim strExtensions As String

  intMonth = Month(Date)
 
  intYear = Year(Date)

  ' The following two lines are for testing purposes only.
  ' The month and year below will be used to format the file name.
  ' If these are commented out then the current month and year will be used.
 
  intMonth = 1 ' **** Comment out this line when you go live. ****
  intYear = 2025 ' **** Comment out this line when you go live. ****
 
  strFolder1 = "C:\Private\Backup1\" ' **** Specify folder one here. Include last '\'. ****
 
  strFolder2 = "C:\Private\Backup2\" ' **** Specify folder two here. Include last '\'. ****
 
  dteDate = DateSerial(intYear, intMonth - 1, 1)
 
  strExtensions = "xlsm,xlsx,xls"

  ' Delete files from Folder 1 for the previous month apart from the latest file.
  If fncGetCountOfFilesForMonthAndYear(strFolder1, strExtensions, Format(dteDate, "MMM YYYY")) > 0 Then
   
    dteEarliest = fncGetEarliestFile(strFolder1, strExtensions)
     
    strLatest = fncGetLatestFileForMonthAndYear(strFolder1, strExtensions, intMonth - 1, intYear, dteEarliest)
     
    Call subDeleteFilesForMonthAndYear(strFolder1, strExtensions, Format(dteDate, "MMM YYYY"), strLatest)
 
  End If
 
  ' Delete files from Folder 2 for the previous month apart from the latest file.
  If fncGetCountOfFilesForMonthAndYear(strFolder2, strExtensions, Format(dteDate, "MMM YYYY")) > 0 Then
   
    dteEarliest = fncGetEarliestFile(strFolder2, strExtensions)
     
    strLatest = fncGetLatestFileForMonthAndYear(strFolder2, strExtensions, intMonth - 1, intYear, dteEarliest)
     
    Call subDeleteFilesForMonthAndYear(strFolder2, strExtensions, Format(dteDate, "MMM YYYY"), strLatest)
 
  End If
     
  dteDate = DateSerial(intYear, intMonth, 1) + TimeSerial(Hour(Time$), Minute(Time$), Second(Time$))
   
  With ActiveWorkbook
   
    strExt = Trim(Mid(.Name, InStrRev(.Name, ".", , vbTextCompare) + 1, 6))
    
    .SaveCopyAs strFolder1 & Replace(.Name, "." & strExt, "", 1) & "-" & Format(dteDate, "DD MMM YYYY hhmmss") & "." & strExt
     
    .SaveCopyAs strFolder2 & Replace(.Name, "." & strExt, "", 1) & "-" & Format(dteDate, "DD MMM YYYY hhmmss") & "." & strExt
   
  End With
   
End Sub

Public Function fncGetCountOfFilesForMonthAndYear(strFolder As String, _
  strExtensions As String, _
  strIncludes As String) As Long
Dim MyFSO As FileSystemObject
Dim MyFile As file
Dim MyFolder As Folder
Dim lngCount As Long

  Set MyFSO = New Scripting.FileSystemObject
 
  Set MyFolder = MyFSO.GetFolder(strFolder)
   
  For Each MyFile In MyFolder.Files
     
    If InStr(1, strExtensions, MyFSO.GetExtensionName(MyFile), vbTextCompare) > 0 And _
      InStr(1, MyFile.Name, strIncludes, vbTextCompare) > 0 Then
     
      lngCount = lngCount + 1
   
    End If
 
  Next MyFile
 
  fncGetCountOfFilesForMonthAndYear = lngCount
   
End Function

Public Function fncGetEarliestFile(strFolder As String, strExtensions As String) As Date
Dim MyFSO As FileSystemObject
Dim MyFile As file
Dim MyFolder As Folder
Dim strEarliest As String
Dim dteDate As Date

  dteDate = Now()

  Set MyFSO = New Scripting.FileSystemObject
 
  Set MyFolder = MyFSO.GetFolder(strFolder)
   
  For Each MyFile In MyFolder.Files
     
    If InStr(1, strExtensions, MyFSO.GetExtensionName(MyFile), vbTextCompare) > 0 Then
       
      If MyFile.DateCreated < dteDate Then
        strEarliest = MyFile.Name
        dteDate = MyFile.DateCreated
      End If
   
    End If
 
  Next MyFile
   
  fncGetEarliestFile = dteDate    ' strEarliest
   
End Function

Public Function subDeleteFilesForMonthAndYear(strFolder As String, _
  strExtensions As String, _
  strIncludes As String, _
  strLatest As String)
Dim MyFSO As FileSystemObject
Dim MyFile As file
Dim MyFolder As Folder
Dim lngCount As Long

  Set MyFSO = New Scripting.FileSystemObject
 
  Set MyFolder = MyFSO.GetFolder(strFolder)
   
  For Each MyFile In MyFolder.Files
     
    If InStr(1, strExtensions, MyFSO.GetExtensionName(MyFile), vbTextCompare) > 0 And _
      InStr(1, MyFile.Name, strIncludes, vbTextCompare) > 0 And _
      MyFile.Name <> strLatest Then
           
      On Error Resume Next
      Kill (strFolder & MyFile.Name)
      On Error GoTo 0
     
      lngCount = lngCount + 1
   
    End If
 
  Next MyFile
     
End Function

Public Function fncGetLatestFileForMonthAndYear(strFolder As String, _
  strExtensions As String, _
  intMonth As Integer, _
  intYear As Integer, _
  dteEarliest As Date)
Dim MyFSO As FileSystemObject
Dim MyFile As file
Dim MyFolder As Folder
Dim strFileExt As String
Dim strLatest As String
Dim dteDate As Date

  Set MyFSO = New Scripting.FileSystemObject
 
  Set MyFolder = MyFSO.GetFolder(strFolder)
   
  For Each MyFile In MyFolder.Files
     
    If InStr(1, strExtensions, MyFSO.GetExtensionName(MyFile), vbTextCompare) > 0 And _
      InStr(1, MyFile.Name, Format(DateSerial(intYear, intMonth, 1), "MMM YYYY"), vbTextCompare) > 0 Then
       
      If MyFile.DateCreated > dteEarliest Then
        strLatest = MyFile.Name
        dteDate = MyFile.DateCreated
      End If
   
    End If
 
  Next MyFile
 
  fncGetLatestFileForMonthAndYear = strLatest
   
End Function

Thank you so much for this! I'll post back after I get it working.