57本目 ファイルの更新時刻の判定

VBA100本ノック 57本目を動画で解説しています。Excelの神髄さんの模範解答はコチラ

---

問題

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

解答

Sub BACKUPフォルダの更新日時や更新日をセルに出力()
    Dim fso As New FileSystemObject:    Set fso = New Scripting.FileSystemObject
    Dim fol As Folder: Set fol = fso.GetFolder(ThisWorkbook.Path & "\BACKUP")
    Dim f As File, ファイル名, 更新日時, 更新日, i, X, Xrow
    i = 2
    For Each f In fol.Files
        ファイル名 = f.Name
        更新日時 = Format(f.DateLastModified, "yyyymmddhhmm")
        更新日 = Format(f.DateLastModified, "yyyymmdd")
        X = WorksheetFunction.XLookup(更新日, Range("C:C"), Range("B:B"), "なし")
        If X = "なし" Then
            Cells(i, 1) = ファイル名
            Cells(i, 2) = 更新日時
            Cells(i, 3) = 更新日
            i = i + 1
        ElseIf X ＜ 更新日時 Then 'シートのセルの値Xより小さい場合、上書き
            Xrow = WorksheetFunction.XLookup(更新日, Range("C:C"), Range("B:B")).Row
            Cells(Xrow, 1) = ファイル名
            Cells(Xrow, 2) = 更新日時
            Cells(Xrow, 3) = 更新日
        End If
    Next
    For Each f In fol.Files    'A列のリストになければファイルを削除
        ファイル名 = f.Name
        If WorksheetFunction.CountIfs(Range("A:A"), ファイル名) ＜ 1 Then
            fso.DeleteFile ThisWorkbook.Path & "\BACKUP\" & ファイル名
        End If
    Next

End Sub