Excelファイルの自動バックアップ

time 2021/02/27

folder VBA

会社でサーバー上に保存してある重要なExcelファイルってありますよね。
複数人でそのファイルを更新しているような

そんなファイルは誰かが誤って削除や移動、壊してしまったりしたら、リカバリーに大変な時間を取られるんですよね。
もしくは完全復活が出来なく仕事に支障をきたしたり・・・

この記事は、そんなファイルを自動でバックアップ出来るようにしたVBA処理をメモっています。

作りたかったもの

既存のExcelファイルにVBAを追記して、以下のバックアップ動作を行わせる
通常の保存操作時にバックグラウンドで同じフォルダ内に用意してあるバックアップ用フォルダにバックアップ(コピー)を行う
仮にバックアップ用フォルダが無ければ、何も行わないし、メッセージも出さない
（ローカル等にコピーして使う場合にエラーメッセージが出ると面倒なので）
バックアップファイルのファイル名は「コピー元ファイル名＋バックアップ時の日時」
バックアップフォルダの容量を制限するために、定数に設定した数のファイル数を超えないように、古いファイルから削除して設定ファイル数を保つ

利用条件

この方法を使うと、Excelブックに記載したVBAコードを保存する為に、Excelファイルの拡張子を「.xlsx」から「.xlsm」に変更する必要があるので注意。

VBAコード

VBA記述は、全て「Bookモジュール」のみ

Const BU_FOLDER_NAME As String = "サンプル_バックアップフォルダ"    '←定数「バックアップフォルダ名」
Const BU_FILE_LIMIT As Integer = 10                                  '←定数「バックアップファイル数」※実用的に100以下位かな


'******************************************************************************
'#保存ボタン押される（CTR+S含)
'メイン処理
'******************************************************************************
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
On Error GoTo ErrExit
    
    '#バックアップフォルダを探す ⇒ 無ければ終了
    If Dir(ThisWorkbook.Path & "\" & BU_FOLDER_NAME, vbDirectory) <> "" Then
        '#バックアップフォルダ内のファイル数が制限数以上なら古いファイルを1つ削除
         If fncFileLimit = False Then
            GoTo ErrExit
         End If
         
        '#バックアップを行う(ファイル名加工含)
         If fncFileCopy = False Then
            GoTo ErrExit
         End If
        
    Else
        Exit Sub
    End If

    Exit Sub
    
ErrExit:
    MsgBox "バックアップ処理にエラーがありました。管理者へご連絡下さい"
    Debug.Print Err.Number & vbCrLf & Err.Description & vbCrLf & "エラー！：Workbook_BeforeSave"
End Sub

'******************************************************************************
'フォルダ内のファイル数が制限数以上なら古いファイルを1つ削除
'エラー無し：True
'******************************************************************************
Function fncFileLimit() As Boolean
On Error GoTo ErrExit
    fncFileLimit = False
    
    Dim FSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim temFile As Object
    Dim comDate As Date
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = FSO.GetFolder(ThisWorkbook.Path & "\" & BU_FOLDER_NAME)

    comDate = Now
    If objFolder.Files.Count >= BU_FILE_LIMIT Then
        For Each objFile In objFolder.Files
            If comDate > objFile.DateCreated Then
                Set temFile = objFile
                comDate = objFile.DateCreated
            End If
        Next
        
        temFile.Delete
        
    End If
    
    fncFileLimit = True

    Exit Function
    
ErrExit:
    fncFileLimit = False
    Debug.Print Err.Number & vbCrLf & Err.Description & vbCrLf & "エラー！：fncFileLimit"
End Function

'******************************************************************************
'ファイルをコピーする（名前変更）
'エラー無し：True
'******************************************************************************
Function fncFileCopy() As Boolean
On Error GoTo ErrExit
    fncFileCopy = False

    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    FSO.CopyFile ThisWorkbook.FullName, ThisWorkbook.Path & "\" & BU_FOLDER_NAME & "\" & _
        Replace(ActiveWorkbook.Name, ".xlsm", "") & "_" & Format(Now, "yyyymmddhhnnss") & ".xlsm"

    fncFileCopy = True

    Exit Function

ErrExit:
    fncFileCopy = False
    Debug.Print Err.Number & vbCrLf & Err.Description & vbCrLf & "エラー！：fncFileCopy"
End Function

Const BU_FOLDER_NAME As String = "サンプル_バックアップフォルダ" '←定数「バックアップフォルダ名」

Const BU_FILE_LIMIT As Integer = 10 '←定数「バックアップファイル数」※実用的に100以下位かな

'******************************************************************************

'#保存ボタン押される（CTR+S含)

'メイン処理

'******************************************************************************

Private Sub Workbook_AfterSave(ByVal Success As Boolean)

On Error GoTo ErrExit

'#バックアップフォルダを探す ⇒ 無ければ終了

If Dir(ThisWorkbook.Path & "\" & BU_FOLDER_NAME, vbDirectory) <> "" Then

'#バックアップフォルダ内のファイル数が制限数以上なら古いファイルを1つ削除

If fncFileLimit = False Then

GoTo ErrExit

End If

'#バックアップを行う(ファイル名加工含)

If fncFileCopy = False Then

GoTo ErrExit

End If

Else

Exit Sub

End If

Exit Sub

ErrExit:

MsgBox "バックアップ処理にエラーがありました。管理者へご連絡下さい"

Debug.Print Err.Number & vbCrLf & Err.Description & vbCrLf & "エラー！：Workbook_BeforeSave"

End Sub

'******************************************************************************

'フォルダ内のファイル数が制限数以上なら古いファイルを1つ削除

'エラー無し：True

'******************************************************************************

Function fncFileLimit() As Boolean

On Error GoTo ErrExit

fncFileLimit = False

Dim FSO As Object

Dim objFolder As Object

Dim objFile As Object

Dim temFile As Object

Dim comDate As Date

Set FSO = CreateObject("Scripting.FileSystemObject")

Set objFolder = FSO.GetFolder(ThisWorkbook.Path & "\" & BU_FOLDER_NAME)

comDate = Now

If objFolder.Files.Count >= BU_FILE_LIMIT Then

For Each objFile In objFolder.Files

If comDate > objFile.DateCreated Then

Set temFile = objFile

comDate = objFile.DateCreated

End If

temFile.Delete

End If

fncFileLimit = True

Exit Function

ErrExit:

fncFileLimit = False

Debug.Print Err.Number & vbCrLf & Err.Description & vbCrLf & "エラー！：fncFileLimit"

End Function

'******************************************************************************

'ファイルをコピーする（名前変更）

'エラー無し：True

'******************************************************************************

Function fncFileCopy() As Boolean

On Error GoTo ErrExit

fncFileCopy = False

Dim FSO As Object

Set FSO = CreateObject("Scripting.FileSystemObject")

FSO.CopyFile ThisWorkbook.FullName, ThisWorkbook.Path & "\" & BU_FOLDER_NAME & "\" & _

Replace(ActiveWorkbook.Name, ".xlsm", "") & "_" & Format(Now, "yyyymmddhhnnss") & ".xlsm"

fncFileCopy = True

Exit Function

ErrExit:

fncFileCopy = False

Debug.Print Err.Number & vbCrLf & Err.Description & vbCrLf & "エラー！：fncFileCopy"

End Function

使用方法

準備

自動バックアップにしたいExcelファイルを変更するので、その前にバックアップを取っておく
自動コピーしたいExcelファイルを開き、ALT+F11ショートカットキーで開くVBE画面のブックモジュールに上記VBAコードをコピペする
定数(コード1行目）「バックアップフォルダ名」にバックアップ用フォルダ名を記載
※目的のExcelファイルを別の場所にコピーして使った場合、偶然同じ名前のフォルダがファイルと同列にあると、バックアップされてしまうので、具体的な名前の方が望ましい。
定数(コード2行目）「バックアップファイル数」にバックアップファイル制限数を記載
上書き保存 ⇒ （注意：ここで拡張子を.xlsmに変更しないとVBAコードが保存されない）
バックアップしたいExcelファイルと同列の位置に上記で決めたフォルダ名の空のフォルダを作る

動作確認

実用化する前に下記のテストを行い十分確認

デスクトップに「テストフォルダ」を作り、その中にExcelファイルとバックアップ用フォルダを入れて、Excelファイルを変更保存する度にバックアップ用フォルダ内に保存ファイルが作られる事を確認。（バックアップファイル数の制限も効いていることを確認）

運用

ファイルの更新作業は、特に今までと変わらない

保存処理直後にバックグラウンドで自動バックアップ処理が行われる
指定したバックアップフォルダ名のフォルダがファイルと同列にあればバックアップ処理をするが、無ければ何も処理しない。
バックアップ処理中にエラーが発生した場合のみメッセージがでる。
⇒ 「バックアップ処理にエラーがありました。管理者へご連絡下さい」