VBA100本ノック 21本目：バックアップファイルの削除

こちらで公開されている、100本ノックに挑戦。
www.excel-ubara.com
素晴らしい教材を公開いただき、ありがとうございます。

上記リンク先から、問題文を転載。

前回はバックアップを一つ作るだけだったが、今回は最新の30個を残すとのこと。
そこで前回の解答を応用して、まずバックアップを50個作ることにした。

Sub VBA_100Knock_20の応用()
    Dim FSO As Scripting.FileSystemObject
    Set FSO = New Scripting.FileSystemObject
    
    ' BACKUPフォルダの存在確認。無ければ作る。
    Dim BackupFolderPath As String
        BackupFolderPath = ThisWorkbook.Path & _
                           "\" & "BACKUP"
        If Not FSO.FolderExists(BackupFolderPath) Then
            MkDir BackupFolderPath
        End If
        
    Dim BackupFileName As String
    Dim i As Long
        For i = 1 To 50
            BackupFileName = FSO.GetBaseName(ThisWorkbook.Name) & _
                             Format(Now, "_yyyymmddhhmmss") & ".xlsm"
            
            ThisWorkbook.SaveCopyAs BackupFolderPath & "\" & _
                                    BackupFileName
        
            Application.Wait [Now()+"00:00:01"]
        Next
End Sub

バックアップが出来たところで、今回の作戦はこうだ。

1. バックアップファイルの数値をキーに、どうファイルのパスをアイテム
   として、辞書を作成する。
2. 辞書のキー情報（配列）の最小値を求め、それに対応するパスを削除する。
3. 削除したキーを辞書から除去する。
4. キーの数が残り三十個になるまで、これを繰り返す。

以上を踏まえて作成したのがこちら。

Sub VBA_100Knock_21()
    Dim FSO As Scripting.FileSystemObject
    Set FSO = New Scripting.FileSystemObject
    
    ' BACKUPフォルダの存在確認。
    Dim BackupFolderPath As String
        BackupFolderPath = ThisWorkbook.Path & _
                           "\" & "BACKUP"
        If Not FSO.FolderExists(BackupFolderPath) Then
            MsgBox "バックアップフォルダは存在しません。"
            Exit Sub
        End If
        
    ' BACKUPファイルの確認。
    ' バックアップの日付とパスで辞書を作成する。
    Dim Dict As Scripting.Dictionary
    Set Dict = New Scripting.Dictionary
    Dim File As Scripting.File
    Dim myReg As VBScript_RegExp_55.RegExp
    Set myReg = New VBScript_RegExp_55.RegExp
        myReg.Pattern = ".*_(\d{12,14})\.xls\w?"
    Dim MC As VBScript_RegExp_55.MatchCollection
        For Each File In FSO.GetFolder(BackupFolderPath).Files
            If myReg.Test(File.Name) Then
                Set MC = myReg.Execute(File.Name)
                Dict(CDbl(MC(0).SubMatches(0))) = File.Path
            End If
        Next

    ' 日付を14桁の数値としたもの。Long型はオーバーフローする。
    Dim OldDate As Double
        Do
            If Dict.Count <= 30 Then
                Exit Do
            End If
            OldDate = WorksheetFunction.Min(Dict.Keys)
            Kill Dict(OldDate)
            Dict.Remove OldDate
        Loop
End Sub

※冒頭リンク先の解答例および解説も、ぜひご一読ください。

参考まで。