Crear backups cada X tiempo

Código 1 (Copia y pega en un MODULO)

Public ProximaCopia As Date

Public UltimoGuardado As Date

Sub IniciarBackups()

    UltimoGuardado = Now

    CrearBackup

    ProgramarBackup

End Sub

Sub ProgramarBackup()

    'cada X tiempo (10 segundos)

    ProximaCopia = Now + TimeValue("00:00:10")

    Application.OnTime EarliestTime:=ProximaCopia, Procedure:="EjecutarBackup"

End Sub

Sub EjecutarBackup()

    'solo si hubo cambios

    If ThisWorkbook.Saved = False Then

        CrearBackup

    End If

    ProgramarBackup

End Sub

Sub CrearBackup()

    Dim carpeta As String

    Dim nombre As String

    'ruta de tu Carpeta y  el nombre de tu fichero

    carpeta = "C:\Users\a2j\Downloads"

    nombre = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1) & "_" & Format(Now, "yyyymmdd_hhmmss") & ".xlsm"

    ThisWorkbook.SaveCopyAs carpeta & nombre

    UltimoGuardado = Now

End Sub

Sub DetenerBackups()

    On Error Resume Next

    Application.OnTime EarliestTime:=ProximaCopia, Procedure:="EjecutarBackup", Schedule:=False

End Sub