Excel自動保存(バックアップ)マクロ バージョン管理 Excel VBA

Excelには自動保存機能がありますが、保存し忘れやExcelが落ちたときに復旧させるものです。

私が欲しかったのは、ファイルを開く時にその時のバックアップを別名で保存してくれるもの。

一般的な『バージョン管理』の簡易版のようなものですね。

調べましたが、標準でそういった機能は無いようでしたので、マクロで作ってみました。一応、誰かの役に立つかもしれませんので、マクロやVBAが分からない人にも組み込めるように説明します。バグ・ミスなど発見された方はコメントに記載していただけると幸いです。

①　まず、新規ブックを作成し、マクロが有効なファイルとして保存します。

(Excel2003以前はそのまま、Excel2007以降は名前を付けて保存→マクロ有効ブック(*.xlsm)として保存)

②　VBAの画面を開きます。開発タブが表示されない場合は、Excelのオプションから「リボンのユーザー設定」→メインタブ画面の「開発」にチェックを入れます。

開発タブ→Visual Basic　をクリック

 

③　Visual Basicの画面が開くので、「参照設定」というオマジナイのような設定をします。

ツール - 参照設定　から、リスト内の

Microsoft Scripting Runtime

にチェックを入れ、ＯＫ

④　コードを入力します。左にある「プロジェクトエクスプローラー」

（無い場合はメニューの表示 - プロジェクトエクスプローラーをクリック、またはCtrl+R）から、

VBAProject - Microsoft Excel Objects - ThisWorkbook

をダブルクリックすると、コードを入力する画面が開きますので、以下のコードを

貼り付けます。

---------コード　以下から------------------------------

Const backupFolderName = "backup"

Const notExistFolderAlart = "フォルダが存在しません"

Private Sub Workbook_Open()

    Dim fso As New FileSystemObject

    Dim myFullPath As String, myPath As String, myName As String, myEx As String, saveEx As String

    Dim newPath As String

    Dim nameCounter As Integer

    Dim nowDateText As String

        

    nowDateText = Format(Now(), "yyyymmdd")

    myFullPath = ThisWorkbook.FullName

    myName = fso.GetBaseName(myFullPath)

    myEx = fso.GetExtensionName(myFullPath)

    myPath = fso.GetParentFolderName(myFullPath)

        

    'バックアップフォルダの存在を確認し、無い場合は作成する

    If Not fso.FolderExists(myBuildPath(fso, myPath, backupFolderName)) Then

        fso.CreateFolder myBuildPath(fso, myPath, backupFolderName)

    End If

    

    'バックアップファイル名を作成する 元のファイル名+日付

    If myEx = "xlsm" Then

        saveEx = "xlsx"

    Else

        saveEx = "xls"

    End If

    newPath = myBuildPath(fso, myPath, backupFolderName, myName & "_" & nowDateText & "." & saveEx)

    

    nameCounter = 2

    Do While fso.FileExists(newPath)

        newPath = myBuildPath(fso, myPath, backupFolderName, _

            myName & "_" & nowDateText & "_" & nameCounter & "." & saveEx)

        nameCounter = nameCounter + 1

    Loop

    

    'バックアップファイルを作成・保存

    copyToBackupFile newPath

    

End Sub

Private Function myBuildPath(fso As FileSystemObject, ParamArray paths())

    Dim i, s

    s = paths(0)

    For i = 1 To UBound(paths)

        s = fso.BuildPath(s, paths(i))

    Next i

    myBuildPath = s

End Function

Private Function copyToBackupFile(newPath As String)

    Dim i

    Dim newBook As Workbook, maxSheet

    

    Application.ScreenUpdating = False

    Application.DisplayAlerts = False

        

    'シート数=1の新しいブックを作る

    Set newBook = Workbooks.Add

    Do While newBook.Worksheets.Count > 1

        newBook.Worksheets(2).Delete

    Loop

    newBook.Worksheets(1).Name = "0exdeletew0"

    

    'シートをコピーする

    maxSheet = ThisWorkbook.Worksheets.Count

    

    For i = 1 To maxSheet

        ThisWorkbook.Worksheets(i).Copy after:=newBook.Worksheets(newBook.Worksheets.Count)

    Next

    

    newBook.Worksheets(1).Delete

    

    '新しいファイル名で保存

    newBook.SaveAs Filename:=newPath

    newBook.Close

    Application.DisplayAlerts = True

    Application.ScreenUpdating = True

End Function

---------コード　以上------------------------------

 

④必要に応じて改造し、保存します。一番上の

Const backupFolderName = "backup"

で、バックアップを作成するフォルダ名を指定しています。変えたい場合は""内に記入します。

【仕様】

・ファイルを開くと、ファイルと同じパスにバックアップフォルダが作成され、

その時の内容が保存されます。バックアップファイル名には日付が付与されます。

同じ日付のファイルの場合は、「_2」「_3」と連番が付与されます。

・バックアップファイルにはマクロが含まれません。元々別のマクロを含むファイルには適しません。

 

・定期的に保存する機能はありません。開く時にその時点のバックアップを保存するものです。