Copie de sauvegarde automatique dans un dossier

Bonjour,

J'ai besoin de faire des copies de sauvegarde automatique de mon fichier (et ce à chaque ouverture de celui-ci)

J'ai trouvé ce scrpit sur le web

Private Sub Workbook_Open()

On Error Resume Next

Run "BU"

End Sub

Private Sub BU()

Dim Ext$, R$, Z$, S$, Y As Boolean

S = Day(Now) Mod 7

R = ActiveWorkbook.Naame: Ext = Right(R, Len(R) - InStr(R, ".") + 1)

R = Left(R, InStr(R, ".") - 1)

Z = "C:NOMFICHIER\" & R & S & Ext

Application.DisplayAlerts = False

If Len(Dir(Z)) = 0 Then

ActiveWorkbook.SaveCopyAs Z

Else

Y = CDate(Left(FileDateTime(Z), 10)) = Date

If Not Y Then ActiveWorkbook.SaveCopyAs Z

End If

Application.DisplayAlerts = True

End Sub

Il me semble très efficace par contre, il fait un enregistrement par jour mais moi j'aurais besoin d'en faire un à chaque ouverture du fichier.

Pouvez-vous m'aider ?

D'avance merci

Bonjour,

Suffit d'ajouter l'heure au nom de la copie...

Un exemple :

Private Sub Workbook_Open()
'On Error Resume Next '==> inutile
Dim Nom As String 'nom du fichier (avec l'heure)
Nom = Format(Now, "yyyy mm dd hhmmss") & " " & ThisWorkbook.Name
Dim repertoire As String 'chemin d'accès au répertoire
repertoire = "C:\test\sauvegardes\" 'à adapter !
If Dir(repertoire & Nom) <> "" Then 'si le fichier n'existe pas (cas de l'ouverture du même fichier dans la même seconde : impossible)
   ThisWorkbook.SaveCopyAs repertoire & Nom 'save copie
End If
End Sub

Re,

Merci bcp pour votre réponse mais je dois surement faire une erreure.

Car quand je copie le scipt dans ThisWorkbook: ça n'enregistre pas de sauvegarde.

Private Sub Workbook_Open()
Dim Nom As String 'nom du fichier (avec l'heure)
Nom = Format(Now, "yyyy mm dd hhmmss") & " " & ThisWorkbook.Naame
Dim repertoire As String 'chemin d'accès au répertoire
repertoire = "C:\Users\Jérôme\Documents\BACK-UP\BACK up ELB" 'à adapter !
If Dir(repertoire & Nom) <> "" Then 'si le fichier n'existe pas (cas de l'ouverture du même fichier dans la même seconde : impossible)
   ThisWorkbook.SaveCopyAs repertoire & Nom 'save copie
End If
End Sub

Avez-vous une idée de mon erreur ?

D'avance merci

Bonjour,

Désolé, je n'ai pas vu votre réponse...

Manque un séparateur entre le répertoire et le nom de fichier...

Remplacer :

repertoire = "C:\Users\Jérôme\Documents\BACK-UP\BACK up ELB" 'à adapter ! Manque un \ en fin de chaine
If Dir(repertoire & Nom)

par :

repertoire = "C:\Users\Jérôme\Documents\BACK-UP\BACK up ELB\" 'Avec le \ en fin de chaine
If Dir(repertoire & Nom)

Merci bcp c etait bien ça. J aurais dû le voir.

Mais pensez vous qu il soit possible de demander qu apres 15 enregistrements il efface le 1er pour le remplacer par le "nouveau 16 ieme". Et ainsi de suite. Toujours garder 15 back up et ne pas devoir effacer toutes les semaines.

D avance merci pour votre aide .

Bonjour,

Oui, c'est possible.

Je vais regarder car il y a plusieurs cas qui pourraient être "embêtant", notamment selon le classement des fichiers dans le répertoire.

En attendant, tu dois avoir des fichiers un peu "farfelus" dans ton dossier : "C:\Users\Jérôme\Documents\BACK-UP\

Des fichiers du style : BACK up ELB2020 02 05 hhmmss ThisWorkbook.Name

A vérifier...

Bjr,

Oui il est vrai que le titre du fichier est un peu long mais ce n est pas grave. Le principal est surtout de tjrs garder les back up . Par contre si vous avez une idée pour limiter le nombre de fichier dans mon dossier back up avec remplacement automatique. Je suis preneur. Merci déjà pour l aide.

Tu n'as pas compris.

Dans le répertoire parent de ton sous-répertoire de sauvegarde, tu as créé des fichiers inutiles. Va voir!

Pour limiter à 15, à chaque sauvegarde, lancer la Sub Limiter ci-dessous : (! adapter l'extension des fichiers de sauvegarde, dans l'exemple "xlsm")

Sub Limiter()
Dim i As Long, S As String
    i = CountFiles("C:\Users\Jérôme\Documents\BACK-UP\BACK up ELB\", "xlsm", S)
    If i > 15 Then 
        If S <> vbNullString Then
            Kill S
        Else
            MsgBox "Erreur, veuillez vérifier votre répertoire"
        End If
   End If
End Sub
Public Function CountFiles(Rep As String, Extens As String, PlusVieux As String) As Long
Dim Count As Long, Fichier As String, D As Date, sReturn As String
    If Dir(Rep & "*." & Extens) <> vbNullString Then
        Fichier = Dir(Rep & "*." & Extens)
        D = FileDateTime(Rep & Fichier): PlusVieux = Rep & Fichier
        Do Until Fichier = ""
            Count = Count + 1
            Fichier = Dir
            If Fichier <> "" Then
                If D > FileDateTime(Rep & Fichier) Then D = FileDateTime(Rep & Fichier): PlusVieux = Rep & Fichier
            End If
        Loop
    End If
    CountFiles = Count
End Function

Parfait, celà fonctionne à merveille ! Merci pour votre aide !

J'ai une dernière question :

Pour l'instant et pour les tests, j'enregistre les back-up sous ce lien

C:\Users\Jérôme\Documents\BACK-UP\SAUVEGARDE\

Ensuite les enregistrement seront sur le réseau

D:\Users\Jérôme..............................\

Mais quand je vais utiliser ceci sur le réseau, j'aimerais faire aussi tout de même une copie sur chaque C:\ de chaque utilisateur . Et que si il n'existe pas. Que les dossiers soit créé automatiquement.

Afin de garder des back-up hors réseau sur chaque PC utilsant le programme.

Donc si je suis par exemple Alex :

Je voudrais savoir si il est possible que VBA crée dans C: ==> document, le dossier \BACK-UP puis le dossier \SAUVEGARDE

C:\Users\Alex\Documents\BACK-UP\SAUVEGARDE\

Pour que le programme puisse enregistrer les back-up sur chaque PC utilisant le programme. Afin de toujours au moins avoir 1 enregistrement sans BUG hors réseau.

Je ne sais pas si celà est envisageable.

Merci pour votre lecture

Que te renvoie le code suivant :

Sub test()
    MsgBox Environ("username")
End Sub

Jérôme

Donc, ton chemin c'est?

C'est??

C'est???

"C:\Users\" & Environ("username") & "\Documents\BACK-UP\SAUVEGARDE\"

Il s'adaptera ainsi à chaque utilisateur.

S'il n'existe pas, tu peux simplement penser à le créer...

Oui bien entendu, mais je voulais qu'il se crée automatiquement.

Que le code crée le dossier sur chaque session, mais ce n'est pas grave. avec les infos reçues celà m'ira très bien.

Merci pour l'aide

Bonjour,

Pour créer un répertoire et tout ces sous-répertoires, s'il le faut ET que s'il le faut :

'en entête du module :
Private Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long

'plus loin dans le code :
Sub CreateDir()
    SHCreateDirectoryEx 0, "C:\Users\" & Environ("username") & "\Documents\BACK-UP\SAUVEGARDE\", ByVal 0&
End Sub

Merci bcp. Je test ça au plus vite .