VBA100本ノック 57本目:ファイルの更新日時
バックアップファイルの各更新日付の最終時刻のファイルだけを残し、他を削除する問題です。
ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。
ファイル名・拡張子を判定しないので、適当なファイルを"BACKUP"フォルダに集めて動作確認してください。
出題
マクロ自身と同階層の"BACKUP"フォルダに多数のバックアップが入っています。
同一の更新日については最終時刻のみを残して他を削除してください。
※つまり各更新日付の最終時刻のファイルだけ残る。
※(簡易版として)ファイル名・拡張子には関係なく更新日時のみで判断
頂いた回答
解説
Key:更新日付
Item:更新日時とファイルパスの配列
同一キー(日付)が存在した場合は更新日時の大小を判定し削除対象かを決めます。
削除対象は順次Collectionに追加していき、最後にCollectionにあるファイルを削除しています。
Sub VBA100_57_01()
Dim objFso As New Scripting.FileSystemObject
Dim objFolder As Folder
Set objFolder = objFso.GetFolder(ThisWorkbook.Path & "\BACKUP")
Dim objFile As File
Dim dic As New Dictionary
Dim col As New Collection
Dim strDate As String, lastDt As Date
For Each objFile In objFolder.Files
lastDt = objFile.DateLastModified
strDate = Format(lastDt, "yyyymmdd")
If Not dic.Exists(strDate) Then
dic.Add strDate, Array(lastDt, objFile.Path)
End If
If lastDt > dic(strDate)(0) Then
col.Add dic(strDate)(1)
dic(strDate) = Array(lastDt, objFile.Path)
ElseIf lastDt < dic(strDate)(0) Then
col.Add objFile.Path
End If
Next
On Error Resume Next
Dim vItem
For Each vItem In col
Err.Clear
objFso.DeleteFile vItem, True
If Err Then
Debug.Print "削除失敗:" & vItem & vbLf & Err.Description
End If
Next
'Set Nothingは省略
End Sub
更新日時で並べ替えて、日付ごとの最大更新日時を取得しても良いでしょう。
Dir → 配列 → Sort関数(365) → Kill
このVBAサンプルは記事補足に掲載しました。
補足
FileSystemObject + Dictionary + Collection
Dir + 配列 + Sort関数(365) + Kill
この組み合わせになります。
Sub VBA100_57_02()
Dim bkPath As String
bkPath = ThisWorkbook.Path & "\BACKUP\"
Dim ary(), cnt As Long
Dim sFile As String
sFile = Dir(bkPath)
Do While sFile <> ""
cnt = cnt + 1
ReDim Preserve ary(1 To 2, 1 To cnt)
ary(2, cnt) = bkPath & sFile
ary(1, cnt) = Format(FileDateTime(ary(2, cnt)), "yyyymmdd hhmmss")
sFile = Dir()
Loop
If cnt = 0 Then Exit Sub
Dim aryS()
With WorksheetFunction
aryS = .Sort(.Transpose(ary))
End With
On Error Resume Next
Dim i As Long, sDateTime As String
sDateTime = aryS(UBound(aryS, 1), 1)
For i = UBound(aryS, 1) - 1 To LBound(aryS, 1) Step -1
If Split(aryS(i, 1))(0) = Split(aryS(i + 1, 1))(0) Then
If aryS(i, 1) < sDateTime Then
Err.Clear
Kill aryS(i, 2)
If Err Then
Debug.Print "削除失敗:" & aryS(i, 2) & vbLf & Err.Description
End If
End If
Else
sDateTime = aryS(i, 1)
End If
Next
End Sub
並べ替えについては、新関数を使わなくてもシートでやれば同じです。
ですが、並べ替えの為だけにシート出力するのはどうしてもVBA記述が面倒に感じてしまいます。
新関数が使えると、VBA記述がだいぶ変わってくると思います。
ただし、ワークシート関数には制限がありますのでご注意ください。
サイト内関連ページ
同じテーマ「VBA100本ノック」の記事
54本目:シートのChangeイベント
55本目:他ブックのマクロを起動
56本目:数式内の自身のシート名を消す
57本目:ファイルの更新日時
58本目:番号リストを簡潔にした文字列で返す
59本目:12ヶ月分のシートを四半期で分割
60本目:「株式会社」の表記ゆれ置換
61本目:「ふりがな」の取得と設定
62本目:独自のZLOOKUP関数を作成
63本目:複数シートの連結
64本目:リンクされた図(カメラ機能)
新着記事NEW ・・・新着記事一覧を見る
VBA100本ノック 68本目:全テキストボックスの転記|VBA練習問題(1月16日)
VBA100本ノック 67本目:ComboBoxとListBox|VBA練習問題(1月15日)
VBA100本ノック 66本目:全サブフォルダからファイルを探す|VBA練習問題(1月13日)
VBA100本ノック 65本目:固定長テキスト出力|VBA練習問題(1月12日)
VBA100本ノック 64本目:リンクされた図(カメラ機能)|VBA練習問題(1月11日)
VBA100本ノック 63本目:複数シートの連結|VBA練習問題(1月9日)
VBA100本ノック 62本目:独自のZLOOKUP関数を作成|VBA練習問題(1月8日)
VBA100本ノック 61本目:「ふりがな」の取得と設定|VBA練習問題(1月6日)
VBA100本ノック 60本目:「株式会社」の表記ゆれ置換|VBA練習問題(1月5日)
VBA100本ノック 59本目:12ヶ月分のシートを四半期で分割|VBA練習問題(1月4日)
アクセスランキング ・・・ ランキング一覧を見る
1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.変数宣言のDimとデータ型|VBA入門
4.マクロって何?VBAって何?|VBA入門
5.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
6.繰り返し処理(For Next)|VBA入門
7.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
8.セルに文字を入れるとは(Range,Value)|VBA入門
9.とにかく書いてみよう(Sub,End Sub)|VBA入門
10.繰り返し処理(Do Loop)|VBA入門
- ホーム
- マクロVBA入門編
- VBA100本ノック
- 57本目:ファイルの更新日時
このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。