【VBA】エクセル保存直前に自動でバックアップを取る

共同で使うエクセルはある日いきなり何者かに破壊される運命にあります。そんな時の為に自動で定期的にバックアップ保存＆破壊したユーザを特定するためのマクロ

備えあれば憂いなし

Excelを共有フォルダに置き、複数人で利用する様な環境にある場合いつか必ずその時はやってきます。

特に弊社は駆け出しVBAerにスキルアップの為保守をやって貰ってるので、

いつやらかしてしまっても大丈夫なように自動でバックアップを帆依存するマクロを追加してみた。

Workbook_BeforeSaveで変更直前にBookのコピーを取る

バックアップを取るなら保存するその直前に保存するのがベスト。

Workbook_BeforeSaveは名前の通り保存が完了する前に呼び出されるので、ここに以下のコードを記載する↓

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

    Dim strPass As String
    Dim WSH As Variant

    Dim fso As New Scripting.FileSystemObject ' Microsoft Scripting Runtimeの参照設定必須
    
    ' マイドキュメントパス+今日の年月日
    Set WSH = CreateObject("WScript.Shell")
    strPass = WSH.SpecialFolders("MyDocuments") & "\" & Format(Date, "yyyymmdd")
    

    ' 今日の年月日フォルダの存在チェック
    If Dir(strPass, vbDirectory) = "" Then
       ' 存在しなければ作成する
       MkDir strPass
    End If
   

    ' 年月日フォルダにエクセルをコピーして保存。ファイル名は時分秒.xlsm
    fso.CopyFile ThisWorkbook.FullName, strPass & "\" & Format(Now, "hhmmss") & "." & fso.GetExtensionName(ThisWorkbook.FullName)
   
End Sub

こうしておく事で、このエクセルが上書き保存される度、その直前にバックアップが自動で取られるようになる↓

これはテスト用なのでローカルに保存してますが、共有フォルダ等のパスに変更して使用しましょう。

ユーザー特定機能を盛り込む

上記に加え、再発防止の意味でもどのユーザが破壊したのかも知っておきたいので、

実行したユーザのMACアドレスか、固定で振っているならIPアドレスのどちらかを追加したい。

これらの情報は以下の様に取得出来る↓

Sub GetAddress()

    Dim objWMI As Object
    Dim objAdapter As Object
   
    Dim strIP As Variant
  
    Set objWMI = GetObject("winmgmts:\\.\root\cimv2").ExecQuery("SELECT * FROM Win32_NetworkAdapterConfiguration Where (IPEnabled = TRUE)")

    For Each objAdapter In objWMI
        
        For Each strIP In objAdapter.IPAddress
            Debug.Print "IP:" & strIP & " MAC:" & objAdapter.MACAddress
            Exit For
        Next
           
    Next
    
End Sub

実行結果↓

後は組み合わせてファイル名にそのまま追記するも良し、アドレス毎にフォルダ分けするも良しお好みに合わせて。

ちなみにコロンはファイル名に出来ないのでMACアドレスを使用する場合はReplace(strMAC, “:”, “”)で取り除きましょう。

タイマー張って定期的にバックアップとって強制終了に備えるってのも面白いかもね(ᵔᴥᵔ)