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

Excel&VBA解説サイト「エクセルの神髄」様出題の問題集、
「VBA100本ノック」に対する私の回答と解説のページです。

100本ノックの出題リストはこちらから
excel-ubara.com

出題：バックアップファイルの削除

#VBA100本ノック 21本目
自身(ThisWorkbook)と同じフォルダに"BACKUP"フォルダがあります。
このフォルダ内に自身のバックアップが以下の名称で多数入っています。
ブック名_yyyymmddhhmm.xlsm
実行日を含め30日分だけ残し、古いファイルは削除してください。
※日付はファイル名で判断

◇ 出題ページはこちら

ソースコード

メインモジュール

Option Explicit

' 100本ノック021：バックアップファイルの削除
Sub バックアップから30日以前のファイルを削除する()
    
    Dim 対象フォルダパス As String
    対象フォルダパス = ThisWorkbook.Path & "\BACKUP"
    
    Dim 対象ファイルLike条件 As String
    対象ファイルLike条件 = Replace(ThisWorkbook.Name, ".xlsm", "_########")
    
    ' 「本ブック名_yyyymmdd.xlsm」になっているファイルリストを取得
    Dim Clc対象ファイル As New Collection
    Set Clc対象ファイル = GetCollectionフォルダ内ファイルリスト( _
        対象フォルダパス, 対象ファイルLike条件, ".xlsm")
    
    ' yyyymmdd部分が本日-30より小さいファイルを削除
    Dim ymd削除対象日 As Long
    ymd削除対象日 = Format(Date - 30, "yyyymmdd")
    Dim ファイル As File
    For Each ファイル In Clc対象ファイル
        
        Dim ymdバックアップ日 As Long
        ymdバックアップ日 = Right(FSO.GetBaseName(ファイル), 8)
                
        If ymdバックアップ日 <= ymd削除対象日 Then
            On Error Resume Next
            ファイル.Delete
            On Error GoTo 0
        End If
        
    Next
    
End Sub

汎用関数モジュール

Option Explicit

' FileSystemObjectの短縮取得
' 参考：https://www.limecode.jp/entry/utility/shortcall-filesystemobject
Public FSO As New FileSystemObject

' フォルダ内のファイルリストの取得
' 参考：https://www.limecode.jp/entry/utility/get-file-list-function-in-folder
Function GetCollectionフォルダ内ファイルリスト(Path対象フォルダ As String _
    , Optional ByVal ファイルLike条件 As String = "*", Optional 対象拡張子 As String = "xlsx" _
    , Optional is下層フォルダまで取得 As Boolean = False) As Collection
    
    ' ファイルが存在しなくても空のコレクションは返す(Nothingは返さない)
    Set GetCollectionフォルダ内ファイルリスト = New Collection
    
    ' 返り値用コレクション
    Dim Clct対象ファイル As New Collection
    
    ' 対象フォルダを取得
    If FSO.FolderExists(Path対象フォルダ) = False Then Exit Function
    Dim 対象フォルダ As Folder
    Set 対象フォルダ = FSO.GetFolder(Path対象フォルダ)

    ' 指定フォルダ内のすべてのファイルを走査
    Dim ファイル As File
    For Each ファイル In 対象フォルダ.Files
        
        ' 条件を満たすファイルの情報をCollectionに格納
        If ファイル.Name Like ファイルLike条件 & "." & 対象拡張子 Then
            Clct対象ファイル.Add ファイル
        End If

    Next ' 指定フォルダ内のすべてのファイルを走査
    
    ' 下層フォルダも取得する場合の再帰処理
    If is下層フォルダまで取得 Then
        
        Dim 子フォルダ As Folder
        For Each 子フォルダ In 対象フォルダ.SubFolders
            
            ' 子フォルダへ本関数を再帰呼出してCollectionを取得
            Dim Clct子フォルダ対象ファイル As Collection
            Set Clct子フォルダ対象ファイル = GetCollectionフォルダ内ファイルリスト _
                (子フォルダ.Path, ファイルLike条件, 対象拡張子, True)
            
            ' 子フォルダのCollectionを本関数のCollectionと結合
            For Each ファイル In Clct子フォルダ対象ファイル
                Clct対象ファイル.Add ファイル
            Next
    
        Next ' 指定フォルダ内のすべてのファイルを走査
        
    End If
    
    ' 最終結果を返す
    Set GetCollectionフォルダ内ファイルリスト = Clct対象ファイル
End Function

解説

ファイルをループし、ファイル名を判定して削除する問題でした。

ファイルをループしながら削除するのもいいのですが、
本問のように

1. 対象のファイルをCollection化
2. Collectionの中身をループして処理

という手順で組むとコードが読みやすくなります。

加えて、削除を実行する前にコレクションの中身をチェックできるなど、
テスト時にも便利な設計にすることが出来ます。

「取得と処理を分ける」というのは大事なテクニックですので、
必要に応じて使えるようになっておきましょう。

また、対象ファイルのCollection化は汎用関数を使用しました。

かなり万能な関数で、ファイル名条件や拡張子を指定でき、
引数の設定で下層フォルダまで再帰処理もしてくれます。

実務でももちろん使用できますので、気に入ったらお持ち帰りください。
www.limecode.jp