Excel保存時のバックアップ作成

PERSONAL.XLSB

Sub backupfile()

' backup file macro
' debug.print var
' Keyboard Shortcut: Ctrl+s

' 【設定方法】　既存のマクロに追記。下記は新規の場合
'
'　１．エクセルを開く
'　２．開発タブのVisual Basicを洗濯
'　３．画面左のプロジェクト画面の空白にて右クリック　?　挿入　?　標準モジュール
'　４．画面右に新規モジュールのコード編集画面が出てくるので、当マクロを貼り付け
'　５．VBエディタを閉じて、エクセルファイルに名前位をつけて保存する。保存場所は以下。
'     C:\username\AppData\Roaming\Microsoft\Excel\PERSONAL.XLSB
'　６．エクセルファイルを開、開発タブのマクロを選択　?　マクロ一覧が表示されていることを確認
'　７．backupfileマクロを選択　?　オプション　?　ショートカットキーに「s」を指定　?　保存　?　終了
'
'【マクロ概要】　Ctrl+sでいつものように保存してください。
'
'　A.開いている更新未反映状態のファイルを別名でバックアップ
'　B.ファイルの更新を反映し、上書き保存
'
'　　※世代数は管理していないため、容量に空きのある限りバックアップファイルが増加
'

  Dim backupdir As String
  Dim wb As String
  Dim ext As String
  Dim objFileSys As Object
  
  Set objFileSys = CreateObject("Scripting.FileSystemObject")
  fullpath = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
  ext = objFileSys.GetExtensionName(ActiveWorkbook.Path & "\" & ActiveWorkbook.Name)
  wb = Replace(ActiveWorkbook.Name, "." & ext, "")
  
  'バックアップ先は下記を変更（末尾に\マークは不要)
      backupdir = "K:\90_FILEBACKUP\EXCEL"
  
  '開いているファイルを別名でコピー　⇒　変更保存前のバックアップ
  'コメントアウトしている行は作業ファイルと同じ改装にバックアップを作成
  '有効になっている行は、backupdir（任意のディレクトリ）へバックアップを作成
  'Format ) Filename_20150910.xlsx
  
    'objFileSys.copyfile fullpath, ActiveWorkbook.Path & "\" & wb "_" & Format(Now(), "yyyymmdd_hhmmss") & "." & ext
    objFileSys.copyfile fullpath, backupdir & "\" & wb & "_" & Format(Now(), "yyyymmdd_hhmmss") & "." & ext
  
  '開いているファイルを上書き保存で、元ファイルを最新状態にする
  Application.DisplayAlerts = False
  ActiveWorkbook.SaveAs fullpath
  Application.DisplayAlerts = True
  
End Sub