忍者ブログ

上書き保存してバックアップ（Word VBA、Excel VBA)

2020年12月02日
会社PCの調子が悪く、win10アップデートをクリーンインストールしたら復活。

エクセルマクロはパーソナルファイルを退避していたけど、
ワードは頭になくて全部飛んでしまった。。。

情報共有としてメールしていた４件は復旧できたのでご紹介。

今回はその第一弾です。


試行錯誤しながら文書作成やプログラミングをやっているとき、
バージョンを管理しながら進めるのが一般的だけど、
名前を付けて保存するのがめんどくさい！

フォルダの中がどんどんふえていくから、ファイル整理もしなきゃいけない。

てな悩みを解決するために作ったマクロです。

仕様
  1. INPUTBOXを表示して、更新内容を入力
  2. バックアップフォルダがなければ作る
  3. 現在のファイルの保存前の状態をバックアップフォルダに保存
  4. 上書き保存
  5. 上書き後の状態をバックアップフォルダに更新内容を追記して保存
バックデータは前回保存日時、アップデートデータは現在日時をファイル名に使用する。


ワード版とエクセル版があり、それぞれCtrl+Shift+Sで発動するように設定。


以下、ソース
【ワード版】
Sub ◆上書き保存してバックアップv10r00()
    Dim バックアップ名 As String, ファイル名 As String, dEXT As String, pos As Long, BKUPpath As String, rc As Long, Savedate As Double
    BKUPpath = ActiveDocument.Path & "\BKUP"
    
    Dim Note As String
    Note = InputBox("ファイル名に記載する更新内容を入力してください。", "更新内容は？")
     
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(BKUPpath) Then
    Else '   "フォルダが存在しない場合は作る"
        FSO.CreateFolder BKUPpath
    End If
    Application.StatusBar = "バックアップ中"
    ファイル名 = ActiveDocument.Name
    pos = InStrRev(ファイル名, ".") '後方検索でHIT位置を返す　前方はInStr 関数
    dEXT = Right(ファイル名, Len(ファイル名) - pos + 1) ' ピリオド付拡張子
    
    Savedate = FileDateTime(ActiveDocument.FullName)
    バックアップ名 = BKUPpath & "\" & Left(ファイル名, Len(ファイル名) - Len(dEXT)) & Format(Savedate, "_yymmdd_hhmm") & "BKUP" & dEXT
    FSO.CopyFile ActiveDocument.FullName, バックアップ名    '上書き保存後に
    
    Application.StatusBar = "上書き保存中"
    ActiveDocument.Save
    
    Application.StatusBar = "最新バックアップ中"
    If Note = "" Then
        バックアップ名 = BKUPpath & "\" & Left(ファイル名, Len(ファイル名) - Len(dEXT)) & Format(Now, "_yymmdd_hhmm") & "UPDT" & dEXT
    Else
        バックアップ名 = BKUPpath & "\" & Left(ファイル名, Len(ファイル名) - Len(dEXT)) & Format(Now, "_yymmdd_hhmm") & "UPDT(" & Note & ")" & dEXT
    End If
    FSO.CopyFile ActiveDocument.FullName, バックアップ名    '上書き保存後に
    
    Set FSO = Nothing
    Application.StatusBar = ""
End Sub

【エクセル版】
※　ActiveDocumentをActiveWorkbookに置換しただけです
Sub ◆上書き保存してバックアップv10r00()
    Dim バックアップ名 As String, ファイル名 As String, dEXT As String, pos As Long, BKUPpath As String, rc As Long, Savedate As Double
    BKUPpath = ActiveWorkbook.Path & "\BKUP"
    
    Dim Note As String
    Note = InputBox("ファイル名に記載する更新内容を入力してください。", "更新内容は？")
     
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(BKUPpath) Then
    Else '   "フォルダが存在しない場合は作る"
        FSO.CreateFolder BKUPpath
    End If
    Application.StatusBar = "バックアップ中"
        
    ファイル名 = ActiveWorkbook.Name
    pos = InStrRev(ファイル名, ".") '後方検索でHIT位置を返す　前方はInStr 関数
    dEXT = Right(ファイル名, Len(ファイル名) - pos + 1) ' ピリオド付拡張子
    
    Savedate = FileDateTime(ActiveWorkbook.FullName)
    バックアップ名 = BKUPpath & "\" & Left(ファイル名, Len(ファイル名) - Len(dEXT)) & Format(Savedate, "_yymmdd_hhmm") & "BKUP" & dEXT
    FSO.CopyFile ActiveWorkbook.FullName, バックアップ名    '上書き保存後に
    
    Application.StatusBar = "上書き保存中"
    ActiveWorkbook.Save
    
    Application.StatusBar = "最新バックアップ中"
    If Note = "" Then
        バックアップ名 = BKUPpath & "\" & Left(ファイル名, Len(ファイル名) - Len(dEXT)) & Format(Now, "_yymmdd_hhmm") & "UPDT" & dEXT
    Else
        バックアップ名 = BKUPpath & "\" & Left(ファイル名, Len(ファイル名) - Len(dEXT)) & Format(Now, "_yymmdd_hhmm") & "UPDT(" & Note & ")" & dEXT
    End If
    FSO.CopyFile ActiveWorkbook.FullName, バックアップ名    '上書き保存後に
    
    Set FSO = Nothing
    Application.StatusBar = ""
End Sub
ショートカットの登録方法
【ワード】
  1. 画面上部のなにもないところで右クリック
  2. リボンのユーザー設定を選択
  3. ショートカットキー：ユーザー設定を選択
  4. 分類：マクロ から 保存したマクロを選択して割り当てるキーを設定

【エクセル】
  1. Alt＋F8でマクロを表示
  2. 該当のマクロを選択してオプションをクリック
  3. 割り当てるキーを設定


PR
Category・Word VBA | Comments(0)
Comment
  Vodafone絵文字 i-mode絵文字 Ezweb絵文字