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
