SOS Macro ou fonction pour archiver mes données chaque jour

[jorox]

Bonsoir à Tous
j'ai une mini boulangerie. j'ai crée sous excel 2010 une interface pour la gestion globale de toutes les activités. Mais j'ai actuellement un problème. Je ne sais pas comment intégrer une fonction ou macro qui va me permettre d'archiver les informations chaque jour. j'ai le fichier ci joint.
pour plus de détail, je voudrais archiver les informations des cellules suivantes: B6:B106, E6:E106, F6:F106, I6:I106, J6:J106, K6:K106, S6:S24, S30:S106, AQ39, F114, F115 et F116.
Merci d'avance je suis à l'écoute.

 

[mapomme]

Re : SOS Macro ou fonction pour archiver mes données chaque jour

Bonsoir jorox et bienvenue sur XLD ,

Un essai basé sur un ancien fichier qui ne répond pas entièrement à la question puisqu'on archive le fichier complet et non pas seulement les éléments demandés. C'était pour un problème de sauvegarde de dernière version de chaque jour. Chaque fois que le fichier est sauvegardé ou bien fermé, on copie le fichier sous un autre nom.

Voyez ce qui en retourne et si ça ne convient pas, revenez nous le dire.

Le code est dans le module de ThisWorkbook:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
  Archiver
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  Archiver
End Sub

et dans module1:

Sub Archiver()
Dim DateEtHeure, Chemin, NomArchive, rep, Fichier, n&

DateEtHeure = Format(Now(), "yyyymmdd") & Format(Time, "hhmmss")
DateEtHeure = DateEtHeure & " le " & Format(Now(), "ddd dd-mmm-yyyy")
DateEtHeure = DateEtHeure & " à " & Format(Time, "hh-mm-ss")

'sauvegarder une copie
rep = MsgBox("Désirez vous sauvegarder une copie ?", _
        vbQuestion + vbDefaultButton1 + vbYesNo)
If rep = vbYes Then
  Chemin = ThisWorkbook.Path
  If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
  NomArchive = "Archive " & DateEtHeure & ".xlsm"
  ThisWorkbook.SaveCopyAs Chemin & NomArchive
  
  'détruire las autres archives du même jour
  ChDir Chemin
  Fichier = Dir("Archive " & Format(Now(), "yyyymmdd") & "*.xlsm")
  Do Until Len(Fichier) = 0 Or n = 10
    If LCase(Fichier) <> LCase(NomArchive) Then Kill Chemin & Fichier
    Fichier = Dir("Archive " & Format(Now(), "yyyymmdd") & "*.xlsm")
    n = n + 1
  Loop
End If

End Sub

 

[Bebere]

Re : SOS Macro ou fonction pour archiver mes données chaque jour

bonjour Jorox,Mapomme
bienvenue
un autre essai
clic bouton et les données demandées vont dans base

 

[jorox]

Re : SOS Macro ou fonction pour archiver mes données chaque jour

Merci beaucoup
ça marche comme je veux
tu es adorable