Excel VBA 逆引き集 | 実務テンプレ完全版（超再利用部品） – バックアップ自動生成

Excel VBA
スポンサーリンク

ねらい：ブック・シート・CSV・版管理まで「毎回同じ手順」で自動バックアップする

バックアップは「いつ」「どこに」「何を」「何世代残すか」をブレなく実行することが命です。VBAなら“時刻スタンプ付きの安全なパス生成→保存形式（XLSX/CSV）→版数ローテーション→整合性チェック→ログ記録”の型にすれば、毎日の業務でも迷わず回せます。初心者でも貼って動くテンプレを、例題付きでかみ砕いて解説します。

共通基盤：時刻スタンプ・安全パス・ログ・簡易整合性チェック

ユーティリティ（貼って動く最小構成）

' ModBackup_Base.bas
Option Explicit

Public Function StampNow() As String
    ' 2025-12-19_1045 のようなスタンプを返す（分粒度）
    StampNow = Format(Now, "yyyy-mm-dd_hhnn")
End Function

Public Function JoinPath(ByVal basePath As String, ByVal name As String) As String
    If Right$(basePath, 1) = "\" Then
        JoinPath = basePath & name
    Else
        JoinPath = basePath & "\" & name
    End If
End Function

Public Function EnsureFolder(ByVal folderPath As String) As Boolean
    On Error Resume Next
    If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath
    EnsureFolder = (Dir(folderPath, vbDirectory) <> "")
    On Error GoTo 0
End Function

Public Sub AppendLog(ByVal logPath As String, ByVal message As String)
    Dim f As Integer: f = FreeFile
    Open logPath For Append As #f
    Print #f, Format(Now, "yyyy-mm-dd hh:nn:ss"); " | "; message
    Close #f
End Sub

Public Function CheckFileExists(ByVal filePath As String) As Boolean
    CheckFileExists = (Dir(filePath) <> "")
End Function

Public Function FileSize(ByVal filePath As String) As Long
    If Dir(filePath) = "" Then FileSize = 0: Exit Function
    Dim f As Object: Set f = CreateObject("Scripting.FileSystemObject").GetFile(filePath)
    FileSize = f.Size
End Function
VB

重要部分の深掘り

  • 時刻スタンプは「yyyy-mm-dd_hhnn」を推奨。ソートが自然で、日次・分単位の重複も避けられます。
  • フォルダ生成は毎回“存在チェック→必要なら作成”で安全化。ログはテキスト追記にすると監査が容易です。
  • 整合性チェックは「存在＋サイズ＞0」の軽量検査から。必要ならハッシュ（MD5/SHA）追加も可能です。

ブック丸ごとバックアップ：XLSX/XLSMの安全保存と版ローテーション

ブック保存テンプレ

' ModBackup_Workbook.bas
Option Explicit

Public Sub BackupWorkbook(ByVal targetWB As Workbook, ByVal backupRoot As String, _
                          Optional ByVal keepGenerations As Long = 7)
    ' 1) フォルダ準備（例：...\Backup\BookName\2025-12-19_1045.xlsx）
    Dim bookName As String: bookName = Replace(targetWB.Name, ".xlsm", "")
    bookName = Replace(bookName, ".xlsx", "")
    Dim bookFolder As String: bookFolder = JoinPath(backupRoot, bookName)
    If Not EnsureFolder(backupRoot) Then MsgBox "バックアップルートを作成できません: " & backupRoot, vbExclamation: Exit Sub
    If Not EnsureFolder(bookFolder) Then MsgBox "ブックフォルダを作成できません: " & bookFolder, vbExclamation: Exit Sub

    ' 2) 保存（拡張子は元に合わせる）
    Dim stamp As String: stamp = StampNow()
    Dim ext As String: ext = IIf(targetWB.FileFormat = xlOpenXMLWorkbookMacroEnabled, ".xlsm", ".xlsx")
    Dim backupPath As String: backupPath = JoinPath(bookFolder, stamp & ext)

    Application.DisplayAlerts = False
    targetWB.SaveCopyAs backupPath
    Application.DisplayAlerts = True

    ' 3) 整合性（存在＋サイズ）
    If Not CheckFileExists(backupPath) Or FileSize(backupPath) = 0 Then
        AppendLog JoinPath(bookFolder, "backup.log"), "FAILED: " & backupPath
        MsgBox "バックアップ失敗（存在しない/サイズ0）: " & backupPath, vbExclamation
        Exit Sub
    End If

    AppendLog JoinPath(bookFolder, "backup.log"), "OK: " & backupPath

    ' 4) 版管理（古い順に削除）
    RotateGenerations bookFolder, ext, keepGenerations
End Sub

Private Sub RotateGenerations(ByVal folder As String, ByVal ext As String, ByVal keep As Long)
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim fl As Object: Set fl = fso.GetFolder(folder).Files
    Dim arr() As Variant, c As Long: c = 0

    Dim fi As Object
    For Each fi In fl
        If LCase$(Right$(fi.Name, Len(ext))) = LCase$(ext) Then
            c = c + 1: ReDim Preserve arr(1 To c)
            arr(c) = fi
        End If
    Next
    If c <= keep Then Exit Sub

    ' タイムスタンプ名前提で古い順に削除（作成日時でソートしてもOK）
    Dim i As Long, j As Long, tmp As Object
    For i = 1 To c - 1
        For j = i + 1 To c
            If arr(i).DateCreated > arr(j).DateCreated Then
                Set tmp = arr(i): Set arr(i) = arr(j): Set arr(j) = tmp
            End If
        Next
    Next
    For i = 1 To c - keep
        On Error Resume Next
        arr(i).Delete True
        On Error GoTo 0
    Next
End Sub
VB

重要部分の深掘り

  • SaveCopyAsは“編集中でも安全にコピー”できるため、定番です。
  • 版ローテーションは「最新keepGenerations件を残して古い順に削除」。スタンプ名×作成日時で確実に制御します。
  • ログは成功・失敗を明記し、後から検証できる形に残します。

シート単位バックアップ：指定シートを新規ブックに保存

シート抜き出し保存テンプレ

' ModBackup_Sheets.bas
Option Explicit

Public Sub BackupSheets(ByVal sheetNames As Variant, ByVal backupRoot As String, Optional ByVal keepGenerations As Long = 10)
    Dim tempWB As Workbook
    Set tempWB = Application.Workbooks.Add(xlWBATWorksheet)

    Dim i As Long
    For i = LBound(sheetNames) To UBound(sheetNames)
        ThisWorkbook.Worksheets(CStr(sheetNames(i))).Copy After:=tempWB.Worksheets(tempWB.Worksheets.Count)
    Next
    ' 初期シート削除
    Application.DisplayAlerts = False
    tempWB.Worksheets(1).Delete
    Application.DisplayAlerts = True

    Dim folder As String: folder = JoinPath(backupRoot, "SheetsBackup")
    If Not EnsureFolder(backupRoot) Or Not EnsureFolder(folder) Then
        MsgBox "フォルダ作成に失敗: " & folder, vbExclamation: Exit Sub
    End If

    Dim path As String: path = JoinPath(folder, "Sheets_" & StampNow() & ".xlsx")
    tempWB.SaveAs Filename:=path, FileFormat:=xlOpenXMLWorkbook
    tempWB.Close SaveChanges:=False

    If Not CheckFileExists(path) Or FileSize(path) = 0 Then
        AppendLog JoinPath(folder, "backup.log"), "FAILED: " & path
    Else
        AppendLog JoinPath(folder, "backup.log"), "OK: " & path
        Call RotateGenerations folder, ".xlsx", keepGenerations
    End If
End Sub
VB

重要部分の深掘り

  • 大元のブック全体を保存できない運用（機密分離など）では“必要なシートだけ”新規ブックに切り出すのが安全です。
  • DisplayAlertsの切替で“シート削除の確認”を無人化。余計なダイアログで止まらないようにします。

CSVエクスポート：テーブルを個別CSVへ、文字化け防止の基本

CSV保存テンプレ

' ModBackup_CSV.bas
Option Explicit

Public Sub ExportTablesToCsv(ByVal wsName As String, ByVal backupRoot As String)
    Dim ws As Worksheet: Set ws = Worksheets(wsName)
    If ws.ListObjects.Count = 0 Then
        MsgBox "テーブルがありません（Ctrl+Tでテーブル化推奨）: " & wsName, vbExclamation
        Exit Sub
    End If

    Dim folder As String: folder = JoinPath(backupRoot, "CSV_" & StampNow())
    If Not EnsureFolder(backupRoot) Or Not EnsureFolder(folder) Then
        MsgBox "フォルダ作成に失敗: " & folder, vbExclamation: Exit Sub
    End If

    Dim lo As ListObject
    For Each lo In ws.ListObjects
        Dim tempWB As Workbook: Set tempWB = Application.Workbooks.Add
        lo.Range.Copy
        tempWB.Worksheets(1).Range("A1").PasteSpecial xlPasteValues
        Dim csvPath As String: csvPath = JoinPath(folder, lo.Name & ".csv")
        Application.DisplayAlerts = False
        tempWB.SaveAs Filename:=csvPath, FileFormat:=xlCSV
        Application.DisplayAlerts = True
        tempWB.Close False
        AppendLog JoinPath(folder, "backup.log"), "CSV: " & csvPath
    Next
End Sub
VB

重要部分の深掘り

  • テーブル（ListObject）単位でCSVにすると、列追加・範囲ズレの事故を防げます。
  • CSVは“値貼り付け”で数式を展開して保存。文字化けが懸念される場合は“UTF-8（xlCSVUTF8）”に変更可能です（Excelのバージョン依存）。

圧縮・署名・自動スケジュール（任意拡張）

ZIP圧縮（軽量、標準機能のみ）

' ModBackup_Zip.bas
Option Explicit

Public Sub ZipFolder(ByVal folderPath As String, ByVal zipPath As String)
    ' WindowsのZIPフォルダ機能を利用（空ZIP作成→シェルコピー）
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(zipPath) Then fso.DeleteFile zipPath, True
    Dim f As Integer: f = FreeFile
    Open zipPath For Output As #f: Close #f
    SetAttr zipPath, vbArchive
    Dim sh As Object: Set sh = CreateObject("Shell.Application")
    sh.NameSpace(zipPath).CopyHere sh.NameSpace(folderPath).Items
    Application.Wait Now + TimeSerial(0, 0, 3) ' 少し待機（大きいフォルダは調整）
End Sub
VB

重要部分の深掘り

  • ZIPは“シェル経由”でシンプルに圧縮できます。ファイル数が多い場合は待機を伸ばすなど実務調整。
  • 署名・ハッシュが必要な現場は、外部ツール連携を想定し、VBA側は「フォルダ構成と名前付け」を厳格にしておくと移行が容易です。

例題の通し方：1クリックで「ブック→シート→CSV→ZIP→ログ」まで

実行例（標準モジュール）

' ModBackup_Example.bas
Option Explicit

Public Sub Run_DailyBackup()
    Dim root As String: root = ThisWorkbook.Path & "\Backup"
    ' 1) ブック全体（7世代）
    BackupWorkbook ThisWorkbook, root, 7

    ' 2) 重要シートのみ（10世代）
    Dim sheets As Variant: sheets = Array("Master", "Detail", "Report")
    BackupSheets sheets, root, 10

    ' 3) テーブルをCSVへ
    ExportTablesToCsv "Detail", root

    ' 4) 今日のバックアップフォルダをZIP（任意）
    Dim todayFolder As String: todayFolder = JoinPath(root, "CSV_" & StampNow()) ' 実際はCSV作成時のフォルダ名を渡す
    Dim zipPath As String: zipPath = JoinPath(root, "Daily_" & StampNow() & ".zip")
    ' ZipFolder todayFolder, zipPath ' フォルダ名を適宜指定

    MsgBox "バックアップが完了しました。", vbInformation
End Sub
VB

期待動作の確認ポイント

  • Backup\ブック名\yyyy-mm-dd_hhnn.xlsx（またはxlsm）が生成され、backup.logにOKが追記される。
  • 指定シートだけのバックアップブックが生成される（SheetsBackup配下）。
  • テーブルごとのCSVがフォルダに出力され、ログが残る。
  • ZIP圧縮はフォルダ指定で一括圧縮される（任意）。

落とし穴と対策（深掘り）

保存中の編集中断・ダイアログ停止

SaveCopyAsで安全コピーし、DisplayAlertsを適切にOFF/ON。無人実行を前提に“止まらない”設計にします。

フォルダ権限・ネットワーク途切れ

EnsureFolderで失敗時に即時通知。ネットワーク共有先を使う場合は、まずローカルに保存→成功後に共有へコピーの二段構えが安全です。

CSVの文字化け

Excelバージョンに応じて xlCSVUTF8 を選択。必要なら“Unicodeテキスト（.txt）→後処理”の運用も検討。

版管理の誤削除

作成日時ソート＋拡張子フィルタで対象を限定。keepGenerationsは環境に合わせて慎重に設定し、初期は多めに残す。

ログが増えすぎて見づらい

1日1ファイルのログ、または月次ログに分割する運用を。ログ行は“日時 | 操作 | パス | 結果”の簡潔な形式に固定します。

まとめ：時刻スタンプ＋安全保存＋版ローテーション＋ログで“壊れない”バックアップ運用にする

  • 保存は“安全コピー”で無人化、出力先は時刻スタンプで衝突回避。
  • 版数ローテーションで容量を制御し、成功・失敗は必ずログに残す。
  • CSV/シート単位/ZIPなど用途別にテンプレを分離し、組み合わせて運用する。

スポンサーリンク
タイトルとURLをコピーしました