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（＆＃34; Scripting.FileSystemObject＆＃34;），经过一些变量修改后，我还没有对它进行测试。

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

2 个答案: