57本目：ファイルの更新日時

出題：ファイルの更新日時

#VBA100本ノック 57本目
マクロ自身と同階層の"BACKUP"フォルダに多数のバックアップが入っています。
同一の更新日については最終時刻のみを残して他を削除してください。
※つまり各更新日付の最終時刻のファイルだけ残る。
※(簡易版として)ファイル名・拡張子には関係なく更新日時のみで判断

◇ 出題ページはこちら

ソースコード

Option Explicit

' 100本ノック057：ファイルの更新日時
Sub BUCKUPフォルダを更新日ごとに最新1ファイルにする()
    
    Dim Path対象フォルダ As String
    Path対象フォルダ = ThisWorkbook.Path & "\BUCKUP"
    
    ' 対象ファイル群のFileオブジェクトをCollectionに格納
    Dim Clct対象ファイル As New Collection
    Set Clct対象ファイル = GetCollectionフォルダ内ファイルリスト _
        (Path対象フォルダ, , "xlsm")
    
    If Clct対象ファイル.Count = 0 Then Exit Sub
    
    ' Keyを更新日とするDictionaryのItemに日ごとの最新のファイルを格納し、
    ' 最新でなかったファイルはその場で削除
    Dim Dic最新ファイル As New Dictionary
    Dim 対象ファイル As File
    For Each 対象ファイル In Clct対象ファイル
        
        Dim key更新日 As Date
        key更新日 = Int(対象ファイル.DateLastModified)
        
        ' 新出の更新日
        If Dic最新ファイル.Exists(key更新日) = False Then
            Dic最新ファイル.Add key更新日, 対象ファイル
        
        ' 既出の更新日は比較して格納 or 削除
        Else
            If Dic最新ファイル(key更新日).DateLastModified _
                           < 対象ファイル.DateLastModified Then
                Dic最新ファイル(key更新日).Delete
                Dic最新ファイル(key更新日) = 対象ファイル
            Else
                対象ファイル.Delete
            End If
        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つに絞る問題です。

こういった「○○ごとに1つ」という処理こそまさにDictionaryの出番で、
更新日をKeyにすることで、更新日ごとに1つのファイルをItemに格納できます。

ファイルのリストを取得する処理は今回も汎用関数を使いました。

対象ファイルのFileオブジェクトをCollectionに格納してくれる関数で、
相当便利な関数なので是非とも採用してみてください。

今回のようなファイルの情報をもとに処理を分岐させるマクロでは、
ファイルをオブジェクトとして扱えるFileSystemObjectの真価が発揮されますね。

DictionaryのItemにファイルのパスを入れるだけだと、
その情報を取得するのにまたひと手間かかってしまいます。

対して今回のようにItemにFileオブジェクトを入れておけば、
.Nameや.Path、今回使った.DateLastModifiedなどを後から取得し放題です。

Keyは更新日、比較は更新日「時」と別のDate型を管理する必要がある問題でしたが、
そのコードを以下のように記述できるのはかなり使い勝手がいいですよね。

Dic最新ファイル(key更新日).DateLastModified

　
そしていざそのItemを削除する際も、

Dic最新ファイル(key更新日).Delete

これで削除ができてしまう便利さです。

FileSystemObjectはこのFile/Folderオブジェクトの扱いに慣れると、
使い道の幅が一気に広がります。

本問もちょうどいい問題でしたので、是非学習してみてください。