Automatic Backup Creator

Sub CreateBackup()
    Dim backupPath As String
    Dim fileName As String
    Dim timestamp As String
    Dim fullBackupPath As String

    ' Create timestamp
    timestamp = Format(Now, "yyyy-mm-dd_hh-mm-ss")

    ' Get current workbook info
    fileName = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)

    ' Set backup path (same directory as original)
    backupPath = ThisWorkbook.Path & "\Backups\"

    ' Create backup directory if it doesn't exist
    If Dir(backupPath, vbDirectory) = "" Then
        MkDir backupPath
    End If

    ' Create full backup path
    fullBackupPath = backupPath & fileName & "_backup_" & timestamp & ".xlsx"

    ' Save backup copy
    Application.DisplayAlerts = False
    ThisWorkbook.SaveCopyAs fullBackupPath
    Application.DisplayAlerts = True

    MsgBox "Backup created: " & vbCrLf & fullBackupPath
End Sub

Sub SetupAutoBackup()
    ' Set up automatic backup on save
    ThisWorkbook.BeforeSave = True
    MsgBox "Auto-backup enabled! A backup will be created each time you save."
End Sub