Excel VBA - 保留 5 个最新备份并删除其余备份

Question

我在 excel 中有一个宏，它在保存之前运行，并创建一个名称中包含实际日期的 excel 表的备份。

这些备份开始占用太多空间，因此我插入了另一个宏来删除超过 14 天的备份。问题是有时我们不会在 2 周或几个月内保存新副本，所以我需要一个只保留 5 个最新备份并删除其余备份的宏。

当前使用的宏：

'======================================================================================
'delete old backup

Set fso = CreateObject("Scripting.FileSystemObject")
For Each fcount In fso.GetFolder(ThisWorkbook.Path & "\" & "excel_backups" & "\").Files

    If DateDiff("d", fcount.DateCreated, Now()) > 14 Then
        Kill fcount
    End If
Next fcount
'======================================================================================

备份以这种格式保存：

ThisWorkbook.Path & "\excel_backups" & "\backup_" & Format(Date, "yyyy.mm.dd") & ".h" & Hour(Now) & "_" & ActiveWorkbook.name

所以备份看起来像这样：backup_2014.12.18.h14_[filename].xlsm

我的问题是：能否以某种方式对其进行修改以仅删除最旧的，并保留最后 5 个最新的？我不知道如何开始写。

感谢您的宝贵时间。

Answer 1

这可能不是最有效的方法，但它似乎可以作为一个起点。

    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")
'add each file to a collection
For Each fcount In fso.GetFolder(ThisWorkbook.Path & "\" & "excel_backups" & "\").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 = 6 To collection.Count
    Kill collection(i)
Next i

End Sub

Function SortCollectionDesc(collection As collection)
'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

Answer 2

这就是我想出的。它会计算备份文件夹中的文件数量（很方便！），将它们一一调用并跟踪哪个是最旧的，最后强制删除最旧的。它会这样做，直到剩余的数量少于六个。

Sub DeleteOldFiles()
    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

    Do Until fso.GetFolder(BackUpPath).Files.Count < 6
        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

我喜欢这样，因为您不必担心名称是什么，而且它可能比排序快一点（这对于五个文件来说应该无关紧要）。

一个警告：它需要 scrrun.dll 库。该参考被称为（在 MS Office 2013 中）Microsoft Scripting Runtime。 FileSystemObject 及其关联的属性和方法都来自这个库。

另外，scrrun.dll 附带一个FileSystemObject.CopyFile 方法。

在一些变量更改之后，所有这些可能也适用于 CreateObject("Scripting.FileSystemObject")，但我还没有测试过。