Sauvegarde automatique Hebdomadaire

Le 31/08/2021 à 15:23

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

22gestion-des-projets-v7.xlsm (174.69 Ko)

Merci d'avance.

Le 01/09/2021 à 02:57

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

48benetop91-gestion-des-projets-v7.xlsm (173.19 Ko)

@+

Le 01/09/2021 à 07:38

Bonjour BrunoM45,

Merci pour ton retour je vais tester cela.

Le backup s'enregistre ou ?

Cordialment.

Le 01/09/2021 à 09:38

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

Le 01/09/2021 à 16:15

Bonjour BrunoM45,

Ok je te tiens au courant lundi pour voir si cela fonctionne correctement;

Encore merci.

Le 02/09/2021 à 08:48

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 ?
Le 02/09/2021 à 09:11

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

17benetop91-gestion-des-projets-v7.xlsm (181.08 Ko)

Edit : modifications apportées :
- date de backup au format américain
- teste si fichier backup déjà existant
- désactivation du rafraichissement écran

Le 02/09/2021 à 12:16

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.

Le 02/09/2021 à 12:48

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

@+

Le 02/09/2021 à 14:08

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.

Le 02/09/2021 à 15:48

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 Aurais-tu la gentillesse de me dire comment faire pour que les sauvegardes aillent dans le dossier "Historique".

En te remerciant par avance.

Cdlt.

Le 02/09/2021 à 15:58

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\"

@+

Le 02/09/2021 à 16:15

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 n'est-ce pas.

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.

Le 02/09/2021 à 16:48

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.

Le 02/09/2021 à 17:06

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.

Rechercher des sujets similaires à "sauvegarde automatique hebdomadaire"