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


Excel VBA - leave 5 newest backups and delete the rest

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

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

当前使用的宏：

1
2
3
4
5
6
7
8
9
10
11
'======================================================================================
'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
'======================================================================================

备份以以下格式保存：

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

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

我的问题是：可以通过某种方式对此进行修改以仅删除最旧的，而保留最新的5个吗？我不知道如何开始写。

谢谢您的时间。

相关讨论

这就是我想出的。它计算备份文件夹中的文件数(方便！)，一一调用它们，并跟踪最旧的文件，最后强行删除最旧的文件。它会一直这样做，直到剩余少于六个为止。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
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脚本运行时。 FileSystemObject及其关联的属性和方法来自此库。

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

在进行一些变量更改后，所有这些可能也可以与CreateObject(" Scripting.FileSystemObject")一起使用，但是我尚未对其进行测试。

相关讨论

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
    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
相关讨论