Sauvegarde automatique Hebdomadaire
Bonjour,
J'ai un fichier excel avec une macro qui va mettre à jour des informations à l'ouverture après avoir choisi de les mettre à jour.j'aimerais que chaque lundi le fichier soit sauvegardé en backup pour avoir un historique et pouvoir retrouver les chiffres des semaines précédente.
Mot de passe de la macro: Aliyah
Merci d'avance.
Bonjour Benetop91
Voici le fichier avec :
1) le code demandé dans ThisWorkbook
2) les codes déplacés dans un module, car ils devraient se trouver là
3) liaison des codes modifiées pour chaque bouton
@+
Bonjour BrunoM45,
Merci pour ton retour je vais tester cela.
Le backup s'enregistre ou ?
Cordialment.
Re,
C'est écrit dans le code, c'est dans le dossier ou se trouve le fichier principal
avec la date du jour d'enregistrement (que j'aurais dû mettre au format américain "yyyy.mm.dd")
Private Sub Workbook_Open()
Dim sPath As String, sNameFic
' Forcer le recalcul au cas ou
Application.Calculate
' Faire la backup si nous sommes lundi
If Weekday(Date, vbMonday) = 1 Then
sPath = ThisWorkbook.Path & "\"
sNameFic = Replace(ThisWorkbook.Name, ".xlsm", "") & Format(Date, "dd.mm.yyyy") & ".xlsm"
ThisWorkbook.SaveCopyAs sPath & sNameFic
End If
End Sub
Bonjour BrunoM45,
Ok je te tiens au courant lundi pour voir si cela fonctionne correctement;
Encore merci.
Bonjour Bruno M45,
Je viens de tester en changeant lundi par jeudi cela fonctionne bien une sauvegarde se fait bien.Par contre, est-il possible dans la sauvegarde de neutraliser la mise à jour des données ?
Re,
J'aurais dû y penser, que je suis bête parfois
J'ai carrément changé le code, je copie la feuille dans un nouveau classeur, puis, je copie/colle les valeurs
Et enfin j'enregistre ce nouveau classeur = plus de mise à jour
Edit : modifications apportées :
- date de backup au format américain
- teste si fichier backup déjà existant
- désactivation du rafraichissement écran
Bonjour à toutes et tous, Benetop91, BrunoM45,
Intéressé par ce code, j'ai suivi ce fil,
Merci à Benetop91, d'avoir posé la question.
Merci BrunoM45 pour ce code, toutefois lorsque le fichier est déjà enregistré, il y a ce message "Le nom de fichier existe déjà"
Du coup je me suis permis d'apporter une modification avec "Application.DisplayAlerts = False" mais je ne sais pas s'il est bien placé.
Et j'ai ajouté pour accélérer un peu le code "Application.ScreenUpdating=False" au début pour éviter le rafraîchissement écran.
@Bruno peux-tu regarder si j'ai pas fait d'erreur s'il te plait ?
Sub Backup()
Dim sPath As String, sNameFic
Dim Wbk As Workbook
Dim Shp As Shape
Application.ScreenUpdating = 0
' Forcer le recalcul au cas ou
Application.Calculate
' Copier la feuille
ThisWorkbook.Sheets("Synthese Projet").Copy
' Définir le nouveau classeur
Set Wbk = ActiveWorkbook
' Avec la feuille copiée
With Wbk.Sheets("Synthese Projet")
' Copier/coller les valeurs de la feuille
.Cells.Copy
.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' Supprimer les boutons
For Each Shp In .Shapes
Shp.Delete
Next Shp
End With
' Enregistrer le classeur sans macro (pas besoin)
sPath = ThisWorkbook.Path & "\"
' Récupérer le nom de ce classeur
sNameFic = Replace(ThisWorkbook.Name, ".xlsm", "") & " Back_" & Format(Date, "dd.mm.yyyy") & ".xlsx"
' Enregistrer le nouveau classeur avec ce nom
Application.DisplayAlerts = 0
Wbk.SaveAs sPath & sNameFic, FileFormat:=xlOpenXMLWorkbook
' Fermer la backup
Wbk.Close SaveChanges:=False
' Effacer les variables objet
Set Wbk = Nothing: Set Shp = Nothing
Application.DisplayAlerts = 1
End Sub
Cordialement.
Salut mdo100 et merci de t'intéresser au sujet
Il ne devrait pas y avoir de doublon, mais effectivement, si le fichier est fermé et ouvert plusieurs fois dans la journée, il y aura problème
J'ai donc changé le code ainsi, qui teste si le fichier du jour existe ou non
Bonne idée pour le ScreenUpdating, perso je préfère mettre False ou True plus parlant que 0 ou 1
Sub Backup()
Dim sPath As String, sNameFic As String, LaDate As String
Dim Wbk As Workbook
Dim Shp As Shape
' Définir la date du fichier de backup au format Américain pour l'ordre alphanumérique
LaDate = Format(Date, "yyyy.mm.dd")
' Chemin d'enregistrement
sPath = ThisWorkbook.Path & "\"
' Vérifier si existe déjà une backup, si OUI, on sort
If Dir(sPath & "*" & LaDate & "*") <> "" Then
' Petit message dans la barre de statut (si on le souhaite)
Application.StatusBar = "Fichier déjà sauvegardé..."
Exit Sub
End If
' Sinon
' Désactiver le rafraichissement écran
Application.ScreenUpdating = False
' Forcer le recalcul au cas ou
Application.Calculate
' Copier la feuille
ThisWorkbook.Sheets("Synthese Projet").Copy
' Définir le nouveau classeur
Set Wbk = ActiveWorkbook
' Avec la feuille copiée
With Wbk.Sheets("Synthese Projet")
' Copier/coller les valeurs de la feuille
.Cells.Copy
.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' Supprimer les boutons
For Each Shp In .Shapes
Shp.Delete
Next Shp
End With
' Récupérer le nom de ce classeur
sNameFic = Replace(ThisWorkbook.Name, ".xlsm", "") & " Back_" & LaDate & ".xlsx"
' Désactiver le message au cas ou doublon
Application.DisplayAlerts = False
' Enregistrer le nouveau classeur avec ce nom et sans macro (pas besoin)
Wbk.SaveAs sPath & sNameFic, FileFormat:=xlOpenXMLWorkbook
' Fermer la backup
Wbk.Close SaveChanges:=False
' Réactiver les messages
Application.DisplayAlerts = True
' Réactiver le rafraichissement écran
Application.ScreenUpdating = True
' Effacer les variables objet
Set Wbk = Nothing: Set Shp = Nothing
End Sub
@Benetop91 code à remplacé dans le fichier ou récupérer la mise à jour
@+
Hello BrunoM45,
C'est moi qui te remercie de m'avoir répondu et ce malgré que je ne sois pas l'auteur de la demande.
Je note tes conseils avisés et la modif du code de vérification du fichier déjà enregistré.
J'ai apporté encore une p'tite modif, en effet lors de l'enregistrement du fichier sauvegardé, toutes les cellules de la feuille sont sélectionnées, alors j'ai ajouté ceci:
'Déselectionner le bloc de cellules actives du fichier sauvegardé
ActiveCell.Select
Ce qui donne pour le code en entier afin que @Benetop91 puisse apponté les modifications nécessaire à son fichier.
Sub Backup()
Dim sPath As String, sNameFic As String, LaDate As String
Dim Wbk As Workbook
Dim Shp As Shape
' Définir la date du fichier de backup au format Américain pour l'ordre alphanumérique
LaDate = Format(Date, "yyyy.mm.dd")
' Chemin d'enregistrement
sPath = ThisWorkbook.Path & "\"
' Vérifier si existe déjà une backup, si OUI, on sort
If Dir(sPath & "*" & LaDate & "*") <> "" Then
' Petit message dans la barre de statut (si on le souhaite)
Application.StatusBar = "Fichier déjà sauvegardé..."
Exit Sub
End If
' Sinon
' Désactiver le rafraichissement écran
Application.ScreenUpdating = False
' Forcer le recalcul au cas ou
Application.Calculate
' Copier la feuille
ThisWorkbook.Sheets("Synthese Projet").Copy
' Définir le nouveau classeur
Set Wbk = ActiveWorkbook
' Avec la feuille copiée
With Wbk.Sheets("Synthese Projet")
' Copier/coller les valeurs de la feuille
.Cells.Copy
.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' Supprimer les boutons
For Each Shp In .Shapes
Shp.Delete
Next Shp
'Déselectionner le bloc de cellules actives du fichier sauvegardé
ActiveCell.Select
End With
' Récupérer le nom de ce classeur
sNameFic = Replace(ThisWorkbook.Name, ".xlsm", "") & " Back_" & LaDate & ".xlsx"
' Désactiver le message au cas ou doublon
Application.DisplayAlerts = False
' Enregistrer le nouveau classeur avec ce nom et sans macro (pas besoin)
Wbk.SaveAs sPath & sNameFic, FileFormat:=xlOpenXMLWorkbook
' Fermer la backup
Wbk.Close SaveChanges:=False
' Réactiver les messages
Application.DisplayAlerts = True
' Réactiver le rafraichissement écran
Application.ScreenUpdating = True
' Effacer les variables objet
Set Wbk = Nothing: Set Shp = Nothing
End Sub
Merci encore @BrunoM45 pour ce code VBA commenté qui me sera certainement utile pour créer un historique semainier d'un de mes fichiers que j'ouvre tous les jours.
Belle journée à toi.
Cordialement.
Re BrunoM45,
En m'invitant sur ce fil, j'ose abuser de tes compétences si tu le veux bien.
Les fichiers sauvegardés sont dans le dossier principal, hors je souhaiterai qu'ils aillent dans le dossier "Historique" qui se trouve dans le dossier principal afin de ne pas cumuler les archives dans le dossier principal.
J'ai tester quelles idées, mais elles ne fonctionnent pas
En te remerciant par avance.
Cdlt.
Re,
je souhaiterai qu'ils aillent dans le dossier "Historique" qui se trouve dans le dossier principal afin de ne pas cumuler les archives dans le dossier principal.
Tu as tout à fait raison à ce sujet, il faut donc modifier ceci
' Chemin d'enregistrement
sPath = ThisWorkbook.Path & "\"
En cela
' Chemin d'enregistrement
sPath = ThisWorkbook.Path & "\Historique\"
@+
Re BrunoM45,
Merci encore d'avoir accédé à ma nouvelle demande, ça fonctionne comme je le souhaitais.
C'est tellement facile quand on sait faire.
Voici ce que j'avais tester, pour te montrer que j'avais travaillé avant de "piouner", mais bof
sPath = ThisWorkbook.Path & "C:\Users\mdo100\Desktop\Nouveau dossier\Historique"
J'ai noté avec attention cette modif, afin de ne plus avoir à demander.
Merci encore, en te souhaitant une belle fin de journée.
Cdlt.
Re,
Merci Bruno M45 et MDO100, pour toutes ses informations.
Cela a l'air de fonctionné de mon côté.
Je reviens vers vous demain pour vous faire un retour.
merci.
Hello Benetop91,
Merci à toi également d'avoir posé la question au début de ce fil, du coup ça m'a donné des idées et avec les améliorations apportées au code de départ, j'ai moi aussi un intérêt certain pour le code de @Bruno.
Cordialement.
PS: Je n'ais aucun doute sur le fonctionnement pour demain, mais j'ai moi aussi fait la modif.