Sauvegarde quotidienne

[Jilde]

Bonjour au forum zé aux forumeurs !

Je suis en train de mettre au point une sauvegarde quotidienne de n'importe quel fichier Excel.
Le but est que, à la première ouverture quotidienne du fichier, Excel en fait une copie dans un répertoire de sauvegarde.
Mais lors des ouvertures suivantes dans la journée, il ne sauvegarde plus.

J'ai pour cela utilisé en grande partie du code trouvé sur le forum, mais la macro a un petit problème.

Voici le code :

Private Sub Workbook_Open()
Dim SFSO ' As Scripting.FileSystemObject
Dim Dossier_Courant
Dim Fichier_Courant
Dim Dossier_Fichier_Courant
Dim Dossier_Sauvegarde
Dim Dossier_Fichier_Sauvegarde

Dossier_Courant = ThisWorkbook.Path
Fichier_Courant = ThisWorkbook.Name
'Supprime l'extension de Fichier_Courant
Fichier_Courant = Split(Fichier_Courant, ".")(0)
Dossier_Fichier_Courant = ThisWorkbook.FullName

'Définition du dossier de sauvegarde
'Attention : Le dossier indiqué doit exister
Dossier_Sauvegarde = "\\Serveur\Sauvegardes\SVG_Base_Cible\"
'Définition du nom complet du fichier de sauvegarde avec la date ajouté au nom du fichier courant
Dossier_Fichier_Sauvegarde = Dossier_Sauvegarde & Fichier_Courant & Format(Date, "-dd-mm-yy") & ".xls"

'Vérification des informations recueillies
MsgBox "Le dossier courant est : " & Chr(13) & Dossier_Courant
MsgBox "Le fichier courant est : " & Chr(13) & Fichier_Courant
MsgBox "Le dossier\fichier courant est : " & Chr(13) & Dossier_Fichier_Courant
MsgBox "Le dossier de sauvegarde est : " & Chr(13) & Dossier_Sauvegarde
MsgBox "Le dossier\fichier de sauvegarde est : " & Chr(13) & Dossier_Fichier_Sauvegarde

'Désactivation de l'affichage
Application.ScreenUpdating = False

'Sauvegarde du fichier
Set SFSO = CreateObject("Scripting.FileSystemObject")
'Vérification de l'exsitance du fichier de sauvegarde
    If Not SFSO.fileexists(Dossier_Fichier_Sauvegarde) Then
        ThisWorkbook.SaveAs Dossier_Fichier_Sauvegarde
        Application.EnableEvents = False
        Workbooks.Open Dossier_Fichier_Courant
        Application.EnableEvents = True
        Dossier_Fichier_Sauvegarde.Close
        Application.ScreenUpdating = True
        'Message de contrôle
        MsgBox "Le fichier a été sauvegarder sous : < " & Nom_Fichier_Sauvegarde & " >."
    Else
        'Message de contrôle
        MsgBox "Le fichier de sauvegarde :  < " & Nom_Fichier_Sauvegarde & " > existe déjà."
        Exit Sub
    End If
End Sub

Tout va bien jusqu'à la fermeture du fichier qui a été créé. Là, il me dit "Objet requis" ...
Il doit manqué une bricole mais je vois pas trop ...

Merci d'avance !!

 

[vbacrumble]

Re : Sauvegarde quotidienne

Bonjour

Une petit simplification pour bien finir la matinée

Pour supprimer l'extension tu peux utiliser le code ci-dessous

Fichier_Courant = Split(Fichier_Courant, ".")(0)
MsgBox Fichier_Courant

 

[Jilde]

Re : Sauvegarde quotidienne

Modification apportée vbacrumble !!
Merci pour cette simplification !!

 

[Jilde]

Re : Sauvegarde quotidienne

CA MAAAARCHE !!!
J'ai pas trop compris le principe mais il fallait mettre :
"Set Fichier_Sauvegarde = ThisWorkbook"
avant le :
"Fichier_Sauvegarde.Close"

Reste plus qu'à mettre ça dans n'importe quel fichier Excel et chaque jour, le fichier est automatiquement sauvegardé.

Private Sub Workbook_Open()
Dim SFSO ' As Scripting.FileSystemObject
Dim Dossier_Courant
Dim Fichier_Courant
Dim Dossier_Fichier_Courant
Dim Fichier_Sauvegarde
Dim Dossier_Sauvegarde
Dim Dossier_Fichier_Sauvegarde

Dossier_Courant = ThisWorkbook.Path
Fichier_Courant = ThisWorkbook.Name
'Supprime l'extension de Fichier_Courant
Fichier_Courant = Split(Fichier_Courant, ".")(0)
Dossier_Fichier_Courant = ThisWorkbook.FullName

'Attention, le dossier "\\Serveur\Sauvegarde\SVG_Excel\" doit exister !!!
Dossier_Sauvegarde = "\\Serveur\Sauvegarde\SVG_Excel\"
Dossier_Fichier_Sauvegarde = Dossier_Sauvegarde & Fichier_Courant & Format(Date, "-dd-mm-yy") & ".xls"

'Vérification facultatives des informations recueillies
'MsgBox "Le fichier courant est : " & Chr(13) & Dossier_Fichier_Courant
'MsgBox "Le fichier de sauvegarde est : " & Chr(13) & Dossier_Fichier_Sauvegarde

'Désactivation de l'affichage
Application.ScreenUpdating = False

'Sauvegarde du fichier
Set SFSO = CreateObject("Scripting.FileSystemObject")
'Vérification de l'exsitance du fichier de sauvegarde
    If Not SFSO.fileexists(Dossier_Fichier_Sauvegarde) Then
        ThisWorkbook.SaveAs Dossier_Fichier_Sauvegarde
        Set Fichier_Sauvegarde = ThisWorkbook
        Application.EnableEvents = False
        Workbooks.Open Dossier_Fichier_Courant
        Application.EnableEvents = True
        Fichier_Sauvegarde.Close
        Application.ScreenUpdating = True
    Else
        Exit Sub
    End If
End Sub

Vive le VBA !!!