和風スパゲティのレシピ

日本語でコーディングするExcelVBA

トップ > 100本ノック > 84本目：ブックの自動バックアップ

84本目：ブックの自動バックアップ

100本ノック ブック・ファイル FileSystemObject VBA

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

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

出題：ブックの自動バックアップ

#VBA100本ノック 84本目
ブックが保存される時に自動的にバックアップを作成してください。
Thisworkbookパスの下の"BACKUP"フォルダに作成。
ブック名_yymmddhhmmss.xlsm
最新の30世代だけを残し、それより古いバックアップは削除してください。
※当該ファイル以外は存在しません。

バックアップしたブックのサンプル

◇ 出題ページはこちら
https://excel-ubara.com/vba100/VBA100_000.html

ソースコード

ThisWorkbookモジュール

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

    If Me.Saved = False Then Call ブックのバックアップを取る(Me)

End Sub

定義モジュール

' バックアップリスト
Public Const Countバックアップファイル数 = 30
Public Const R1stバックアップリスト = 2
Public Const C1stバックアップリスト = 1
Public Enum CNoバックアップリスト
    ファイル名 = C1stバックアップリスト
    ファイルパス
End Enum
Public Const CLastバックアップリスト = CNoバックアップリスト.ファイルパス

メインモジュール

Option Explicit

' 100本ノック084：ブックの自動バックアップ
Sub ブックのバックアップを取る(対象ファイル As Workbook)

    ' 保存フォルダの取得(なければ作成)
    Dim Path保存フォルダ As String
    Path保存フォルダ = 対象ファイル.Path & "\BACKUP"
    If Dir(Path保存フォルダ, vbDirectory) = "" Then MkDir (Path保存フォルダ)

    ' ブック名の生成
    Dim 保存ブック名 As String
    保存ブック名 = Replace(対象ファイル.Name, ".xlsm", Format(Now(), "_yyyymmddhhmmss") & ".xlsm")
    
    ' ブックのコピーを保存
    対象ファイル.SaveCopyAs Path保存フォルダ & "\" & 保存ブック名
    
    ' バックアップファイルの個数管理
    Call 規定数を超えたバックアップファイルを削除する(Path保存フォルダ)
    
End Sub

' バックアップファイルの個数管理
Sub 規定数を超えたバックアップファイルを削除する(Path対象フォルダ As String)
    
    ' フォルダ内のファイルリストを取得
    Dim Clct対象ファイル As Collection
    Set Clct対象ファイル = GetCollectionフォルダ内ファイルリスト(Path対象フォルダ, , "xlsm")
    
    ' ファイルをシートに書き出し
    Dim R As Long: R = R1stバックアップリスト
    Dim ファイル As File
    For Each ファイル In Clct対象ファイル
        WSバックアップリスト.Cells(R, CNoバックアップリスト.ファイル名) = ファイル.Name
        WSバックアップリスト.Cells(R, CNoバックアップリスト.ファイルパス) = ファイル.Path
        R = R + 1
    Next
    
    ' ファイルリストをソート
    Dim Rangeファイルリスト As Range
    Set Rangeファイルリスト = GetRangeフィルターデータ部分(WSバックアップリスト)
    Rangeファイルリスト.Sort WSバックアップリスト.Cells(1, CNoバックアップリスト.ファイル名), xlDescending
    
    ' 規定数を超えるファイルを削除
    Dim R_削除対象行 As Long: R_削除対象行 = R1stバックアップリスト + Countバックアップファイル数
    Do Until WSバックアップリスト.Cells(R_削除対象行, C1stバックアップリスト) = ""
        FSO.DeleteFile WSバックアップリスト.Cells(R_削除対象行, CNoバックアップリスト.ファイルパス)
        WSバックアップリスト.Rows(R_削除対象行).Delete
    Loop
    
End Sub

汎用関数モジュール

Option Explicit

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

' 最終行の取得
' 参考：https://www.limecode.jp/entry/library/get-lastrow-lastcolumn
Function Get最終行(指定オブジェクト As Variant, Optional ByVal C As Long = -1) As Long

    ' 渡されたオブジェクトからセル範囲を取得
    Dim 対象セル範囲 As Range
    Select Case TypeName(指定オブジェクト)
    Case "Range"
        If 指定オブジェクト.Cells.CountLarge = 1 Then ' 単独セルにはCurrentRegionを取る
            Set 対象セル範囲 = 指定オブジェクト.CurrentRegion
        Else
            Set 対象セル範囲 = 指定オブジェクト
        End If
    Case "Worksheet"
        Set 対象セル範囲 = 指定オブジェクト.UsedRange
    Case "AutoFilter", "ListObject"
        Set 対象セル範囲 = 指定オブジェクト.Range
    Case Else
        Err.Raise 1000, , "対象外のオブジェクト「" & TypeName(指定オブジェクト) & "」が指定されました。"
    End Select

    ' エリアの最終行を取得
    Get最終行 = 対象セル範囲.Rows.Count + 対象セル範囲.Row - 1

    ' 列が指定されていればその列の入力最終行を取得
    If C <> -1 Then
        Do While 対象セル範囲.Worksheet.Cells(Get最終行, C) = ""
            Get最終行 = Get最終行 - 1
            If Get最終行 < 対象セル範囲.Row Then
                Get最終行 = 0
                Exit Function
            End If
        Loop
    End If

End Function

' フィルターデータ部
' 参考：https://www.limecode.jp/entry/utility/get-autofilter-datarange
Function GetRangeフィルターデータ部分(指定シート As Worksheet) As Range
    If 指定シート.AutoFilterMode = False Then Exit Function
    
    Dim フィルターデータ部 As Range
    Set フィルターデータ部 = 指定シート.AutoFilter.Range
    
    If フィルターデータ部.Rows.Count = 1 Then Exit Function
    
    Set フィルターデータ部 = フィルターデータ部.Offset(1)
    Set フィルターデータ部 = フィルターデータ部.Resize(フィルターデータ部.Rows.Count - 1)
    
    Set GetRangeフィルターデータ部分 = フィルターデータ部

End Function

' フォルダ内のファイルリストの取得
Function GetCollectionフォルダ内ファイルリスト(Path対象フォルダ As String _
    , Optional ByVal ファイルLike条件 As String = "*", Optional 対象拡張子 As String = "xlsx" _
    , Optional is下層フォルダまで取得 As Boolean = False) As Collection
    
    Dim Clct対象ファイル As New Collection
    
    ' 対象フォルダを取得
    If FSO.FolderExists(Path対象フォルダ) = False Then Exit Function
    Dim 対象フォルダ As Folder
    Set 対象フォルダ = FSO.GetFolder(Path対象フォルダ)
    If 対象フォルダ.Files.Count = 0 Then Exit Function

    ' 指定フォルダ内のすべてのファイルを走査
    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
            
            ' 子フォルダへ本関数を再帰実行してDictionaryを取得
            Dim Clct子フォルダ対象ファイル As Collection
            Set Clct子フォルダ対象ファイル = GetCollectionフォルダ内ファイルリスト _
                (子フォルダ.Path, ファイルLike条件, 対象拡張子, True)
            
            ' 子フォルダのDictionaryを本関数のDictionaryと結合
            For Each ファイル In Clct子フォルダ対象ファイル
                Clct対象ファイル.Add ファイル
            Next
    
        Next ' 指定フォルダ内のすべてのファイルを走査
        
    End If
    
    ' 最終結果を返す
    Set GetCollectionフォルダ内ファイルリスト = Clct対象ファイル
End Function

解説

バックアップ自体は簡単な「コピーを保存」する処理です。

WorkbookオブジェクトのSaveCopyAsメソッドを使用することで、
現在のブックとは別のファイルにブックを保存することが可能です。


肝心の「30世代を残して削除」する部分ですが、
今回はファイル名が規則正しく並んでくれる仕様ですので、
単純にファイル名順に並び替えて31番目以降のファイルを削除しています。


並び換えを配列でやろうとするとソートロジックが必要になるため、
シートに書き出してRangeオブジェクトのSortメソッドを使用しました。

Excelのソートは十分高速ですし、何よりシート上で並び換えると目に見えるため、
配列をメモリ上で並び替えするよりコーディングもデバッグも格段にやりやすいです。


ExcelVBAのソートは基本すべてシート上でやってしまっていいと思いますので、
積極的にワークシートを活用していきましょう。


最後にファイルをループする部分ですが、
こちらはFileSystemObjectのループ処理を内包した汎用関数を使用しています。

フォルダパスと検索条件を引数として渡すと、
対象のFileオブジェクト集をCollectionとして渡してくれる関数ですね。


フォルダ内のファイルループは書くと結構長くなる部分ですので、
複雑な処理でなければ汎用関数で済ませてしまいたいところです。

今回のようにファイルの検索処理を、
「フォルダパス」を渡すと「ファイル集のリスト」を返してくれる
関数にしておくと格段にコードが短くなります。

本問を参考に皆さんも汎用関数を作ってみてください。


本関数についての詳しい解説はこちらをどうぞ。
[準備中]