"macro excel création et effacement auto&quot Résolu

Question

je suis ici :)

jah_haile_selassie · Answer

En faite j'arrive a créer le sous dossier mais il ne me crèè pas mes fichiers excel dans ce sous dossier; Et en plus il me crèe les fichiers dans le dossier principal avec un nom de la forme--->10_04_2009test- 10-4-2009 - 14H50m26s.xls

pijaku · Answer

remettons tout cela pour faire de l'ordre...
Le but est de faire une macro qui enregistre automatiquement (toutes les heures si j'ai bien compris) un classeur excel dans un répertoire "du jour" et qui à l'ouverture supprime d'anciennes sauvegardes de ce fichier. Nous en étions là du code :

Sub creation() 'fonction qui créé le sous-répertoire à la date du jour et effectue les sauvegardes de ton classeur
Dim Chemin As String
Dim fname As String
Dim jour As String
jour = Format(Date, "dd_mm_yyyy")
MkDir "\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\" & jour
debut:
Start = Timer
intervalle = 60
Do While Timer < Start + intervalle
DoEvents ' Donne le contrôle à d'autres processus.
Loop
Chemin = "\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\"
fname = Chemin & "test- " & Day(Date) & "-" & Month(Date) & "-" & Year(Date) & " - " & Hour(Time) & "H" & Minute(Time) & "m" & Second(Time) & "s" & ".xls"
ActiveWorkbook.SaveCopyAs FileName:=fname
GoTo debut
End Sub

Sub auto_open() 'fonction qui supprime les anciennes sauvegardes
Dim var, Fic As String
var = InputBox("Saisir la date à laquelle vous souhaitez effacer les fichiers. Attention bien saisir au format dd_mm_yyyy!!", "date d'effacement")
Fic = Dir("\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\" & var)
If Fic <> "" Then
Kill "\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\" & Fic
Else
MsgBox ("le sous-dossier que vous souhaitez effacer est vide. Veuillez vérifier.")
End If
End Sub

Private Sub Workbook_Open() 'ta macro
Dim Chemin As String
Dim fichierTexte As String
Chemin = "\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\"
NomFic = Day(Date) & "-" & Month(Date) & "-" & Year(Date) & ".txt"
If Dir(Chemin & NomFic) = "" Then 'si le fichier de la date du jour n'existe pas
Call auto_open ' on lance l'effacement
Set fs = CreateObject("Scripting.FileSystemObject") 'on crée le fichier date du jour
Set a = fs.CreateTextFile(Chemin & NomFic, True)
a.Close
Call creation 'on appelle l'autre proc
End If ' Il n'y a pas de sinon puisque si le fichier existe on ne fait rien
Call creation 'on appelle l'autre proc
End Sub

jah_haile_selassie · Answer

Oui c'est bien ça!! Nous somme là

jah_haile_selassie · Answer

J'ai pris ce code et je vais l'éxécuter

jah_haile_selassie · Answer

J'ai éxécuter  le code sans changement et j'ai cette erreur---> erreur d'exécution '75'  ---> erreur d'accès chemin/Fichier et c'est sur mkdir--->MkDir "\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\" & jour.

pijaku · Answer

Oui en fait, une fois que ton sous-répertoire est créé il plante car on ne peux pas créer 2 répertoire au même nom. Ca n'est pas un souci...

jah_haile_selassie · Answer

Oui mais j'ai le repertoire qui se crèe quan même . Le truc aussi c'est que la macro ne crèe pa les fichiers dans mon sous dossier alors qu'elle devrai le faire

pijaku · Answer

oui je suis en train de chercher pour cela... Par contre ils sont tous sauvegardés dans ton rép "Mes Documents" non?

jah_haile_selassie · Answer

Non ; mon fichier test est sur mon bureau et mes sauvegarde je les mets sur un serveur distant. Je te remercie mec pour ton aide précieuse

pijaku · Answer

Voici pour la sub creation :

Sub creation() 
Dim Chemin As String
Dim fname As String
Dim jour As String
jour = Format(Date, "dd_mm_yyyy")
Chemin = "\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\" & jour
If Dir(Chemin, vbDirectory) = "" Then 'ça je n'ai pas testé........
MkDir Chemin
End If
debut:
Start = Timer
intervalle = 60
Do While Timer < Start + intervalle
DoEvents 
Loop
fname = "test- " & Day(Date) & "-" & Month(Date) & "-" & Year(Date) & " - " & Hour(Time) & "H" & Minute(Time) & "m" & Second(Time) & "s" & ".xls"
ActiveWorkbook.SaveCopyAs Chemin & "\" & fname
GoTo debut
End Sub

Utilisateur anonyme · Answer

Bonjour, permettez moi de rvenir dans cette nouvelle discussion

jah_haile_selassie, quand tu dis:
Oui mais j'ai le repertoire qui se crèe quan même . Le truc aussi c'est que la macro ne crèe pa les fichiers dans mon sous dossier alors qu'elle devrai le faire

ben effectivement , mais si tu regardais le code pour le comprendre tu verrais que:

dans ta sub creation on crée un répertoire:
jour = Format(Date, "dd_mm_yyyy")
MkDir "\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\" & jour 

et on sauvegarde les fichiers dans:
Chemin = "\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\"
fname = Chemin & "test- " & Day(Date) & "-" & Month(Date) & "-" & Year(Date) & " - " & Hour(Time) & "H" & Minute(Time) & "m" & Second(Time) & "s" & ".xls"
ActiveWorkbook.SaveCopyAs FileName:=fname 

quand tu dis :
J'ai éxécuter le code sans changement et j'ai cette erreur---> erreur d'exécution '75' ---> erreur d'accès chemin/Fichier et c'est sur mkdir--->MkDir "\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\" & jour.

Le répertoire est crée sans vérifier qu'il existe déjà! De plus dans la proc Workbook_Open() , à la premiere ouverture de ton classeur tu fais appel 2 fois à ta proc    'creation' . Il faut supprimer l'appel qui est dans le if......end if.

Le but est bientôt atteint
bon courage

jah_haile_selassie · Answer

Oui comme dit Priouman j'avance! mais a trop petit pas mais merci a vous les mecs! sincèrement... J'ai modifié mon appel de la creation dans le bloc if...end...if comme me l'as conseillé Priouman. J'ai copié la sub creation de Pijaku. J'arrive a créer mon sous dossier et sauvegarder des fichiers dans ce sous-dossier ce que je n'arrivait pas a faire précedemment. 
Une question persiste pourquoi on me demande la date a laquelle je veux supprimer des fichiers même quand je n'ai pas encore de sous dossier créé? Et en plus ma suppression de fichier il me dit tjrs que le sous dossier est vide alors qu'il contient des fichiers excels? Ce qui veut dire que ma suppression ne fonctionne plus :( 
Merci et merci encore car c'est pas facile d'aider quelqu'un avec autant de difficulté mais bon je suis pour comprendre ce p*t** de langage.
Bonne soirée.

Jah

pijaku · Answer

Bon premier pallier atteints, la fonction creation fonctionne bien. 2ème pallier maintenant, l'effacement... Au passage je m'excuse auprès des modérateurs pour la longueur de nos 2 topics, mais nous débutons et on y va pas à pas pour bien comprendre ce que l'on fait... question 1 : pourquoi on me demande la date a laquelle je veux supprimer des fichiers même quand je n'ai pas encore de sous dossier créé? réponse : on a placé une inputbox pour cela. Si tu veux qu'elle ne s'ouvre que si tu as des anciennes sauvegardes, il faut d'abord faire un test : Sub auto_open() Dim var, Fic As String If Dir("\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\", vbDirectory) <> "" Then var = InputBox("Saisir la date à laquelle vous souhaitez effacer les fichiers. Attention bien saisir au format dd_mm_yyyy!!", "date d'effacement") else exit sub end if question 2 : Et en plus ma suppression de fichier il me dit tjrs que le sous dossier est vide alors qu'il contient des fichiers excels? réponse : euh plus le temps, je regarderais ça ce soir ou ce week end. Ou alors quelqu'un d'autre peux t'il te répondre??? Le problème se trouve dans ces quelques lignes : Fic = Dir("\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\" & var) If Fic <> "" Then Kill "\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\" & Fic '????? Else MsgBox ("le sous-dossier que vous souhaitez effacer est vide. Veuillez vérifier.") End If End Sub

pijaku · Answer

Maintenant voyons voir l'effacement (la sub complète!!!) Attention les yeux ça décoiffe!!! (elle n'est pas de moi, je l'ai pompé sur un autre forum mais comme il n'y a que CCM qui compte, on s'en fiche non???)
L'inputbox est maintenant inutile. En effet, nous avons créé des sous-dossiers et c'est ça qu'il faut effacer :

Sub auto_open() 
Dim FS
    Set FS = CreateObject("Scripting.FileSystemObject")
    FS.Deletefolder "\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\*.*"
End Sub

Je récapitule donc la macro en entier :

Private Sub Workbook_Open() 'la macro s'exécute à l'ouverture du classeur
Dim Chemin, NomFic As String
Chemin = "\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\"
NomFic = Day(Date) & "-" & Month(Date) & "-" & Year(Date) & ".txt"
If Dir(Chemin & NomFic) = "" Then 'si le fichier de la date du jour n'existe pas
Call auto_open ' on lance l'effacement
Set fs = CreateObject("Scripting.FileSystemObject") 'on crée le fichier date du jour
Set a = fs.CreateTextFile(Chemin & NomFic, True)
a.Close
End If ' Il n'y a pas de sinon puisque si le fichier existe on ne fait rien
Call creation 'on appelle l'autre proc
End Sub

Sub creation()
Dim Chemin, fname, jour As String
jour = Format(Date, "dd_mm_yyyy")
Chemin = "\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\" & jour
If Dir(Chemin, vbDirectory) = "" Then 'Si le sous-dossier nommé "jour" d'aujourd"hui n'a pas encore été créé
MkDir Chemin 'et ben... on le créé
End If
debut:
Start = Timer
intervalle = 60
Do While Timer < Start + intervalle
DoEvents
Loop
fname = "test- " & Day(Date) & "-" & Month(Date) & "-" & Year(Date) & " - " & Hour(Time) & "H" & Minute(Time) & "m" & Second(Time) & "s" & ".xls"
ActiveWorkbook.SaveCopyAs Chemin & "\" & fname
GoTo debut
End Sub

Sub auto_open() 
Dim FS
    Set FS = CreateObject("Scripting.FileSystemObject")
    FS.Deletefolder "\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\*.*"
End Sub

Voilà une bien jolie macro qui devrait figurer dans les astuces de CCM!!!
Mais avant tout, teste la pour vérifier tout ça.

pijaku · Answer

Salut, Tu dois définir var avant de tester si le dossier existe. Tu as fait ceci : If Dir("\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\", vbDirectory) <> "" Then Set FS = CreateObject("Scripting.FileSystemObject") var = InputBox("Saisir la date à laquelle vous souhaitez effacer les fichiers. Attention bien saisir au format dd_mm_yyyy!!", "date d'effacement") Donc d'abord tu testes l'existence de ton dossier et ensuite tu en définit le nom..... Fais comme ceci : var = InputBox("Saisir la date à laquelle vous souhaitez effacer les fichiers. Attention bien saisir au format dd_mm_yyyy!!", "date d'effacement") If Dir("\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\" & var, vbDirectory) <> "" Then Set FS = CreateObject("Scripting.FileSystemObject") ensuite pour effacer le sous dossier tu avais : FS.Deletefolder "\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\*.*" *.* = tous les sous-dossiers... Donc à remplacer par : FS.Deletefolder "\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\" & var Je pense que cela fonctionne. Par contre vérifier ou placer le "& var" si c'est dans les guillemets ou non ça je ne sais plus...

pijaku · Answer

euuhhhhh... J'en sais rien, comme je te disais plus haut je l'ai pompé intégralement sur Internet et te l'ai remise comme ça, intégralement sans chercher à comprendre... Il s'agit certainement d'une procédure vba propre à excel... Mais je dis certainement une grosse c***erie...

jah_haile_selassie · Answer

Oui en effet j'ai cette erreur parceque FS n'est pas un string mais un Objet bon enfin c'est l'explication que j'ai vu par rapport a l'erreur car quand je met Dim FS As String l'erreur me dit Objet requis

pijaku · Answer

Sinon ta macro fonctionne maintenant ?

jah_haile_selassie · Answer

oui elle fonctionne bien pour me créer mes fichiers dans les sous dossiers  mais c'est a l'effaçage que je bute tjrs! J'arrive a effacer l'ensemble des sous dossiers mais effacer un dossier en particulier nada!

J'ai cherché un peu ailleurs et j'ai eu ça:
Sub auto_open()
Dim myFso, myFile, myFolder
Set myFso = CreateObject("Scripting.FileSystemObject")
'sélection du dossier à analyser
Set myFolder = myFso.GetFolder("\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\")
'boucle sur tous les fichier du dossier
For Each myFile In myFolder.Files
    'si la date de modification du fichier est antérieure à 3 jours, effacer le fichier
    If DateDiff("d", myFile.DateLastModified, Now) > 1 Then myFile.Delete True
Next myFile
End Sub
Mais avec ça la différence c'est que ça ne tien pas compte des noms fichiers étant donné que les fichiers son sous cette forme:test- 14-4-2009 - 15H24m45s.xls. Et ça ne tient pas compte peut-etre de mes sous dossiers lol harff casse-tête japonais

jah_haile_selassie · Answer

L'effacement fonctionne mais la je ne sais pas comment l'obliger a effacer dans les sous dossiers ou bien arréter la création des fichiers dans des sous dossier mais dans le dossier principal!

pijaku · Answer

Alors je ne peux plus t'aider là dessus... Essaie un nouveau post en expliquant bien ton souci...
A+

jah_haile_selassie · Answer

Pijaku Merci mec!
ça marche nikel!! j'ai testé et c'est bon.  J'ai adapté la macro effacer que j'ai pris ailleurs et en plus j'ai enlever la création des sous dossiers pour l'obliger a effacer le contenu du dossier principal.

Donc pour recupituler j'arrive a effacer des fichier sauvegarder il y'a de cela trois jours. Et l'effcement se lance une seule fois! Merci encore mec :

Voici mon code complet:

Private Sub Workbook_Open() 'la macro s'exécute à l'ouverture du classeur
Dim Chemin, NomFic As String
Chemin = "\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\"
NomFic = Day(Date) & "-" & Month(Date) & "-" & Year(Date) & ".txt"
If Dir(Chemin & NomFic) = "" Then 'si le fichier de la date du jour n'existe pas
Call auto_open ' on lance l'effacement
Set FS = CreateObject("Scripting.FileSystemObject") 'on crée le fichier date du jour
Set a = FS.CreateTextFile(Chemin & NomFic, True)
a.Close
End If ' Il n'y a pas de sinon puisque si le fichier existe on ne fait rien
Call creation 'on appelle l'autre proc
End Sub

Sub auto_open()
Dim myFso, myFile, myFolder
Set myFso = CreateObject("Scripting.FileSystemObject")
'sélection du dossier à analyser
Set myFolder = myFso.GetFolder("\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\")
'boucle sur tous les fichier du dossier
For Each myFile In myFolder.Files
    'si la date de modification du fichier est antérieure à 3 jours, effacer le fichier
    If DateDiff("d", myFile.DateLastModified, Now) > 2 Then myFile.Delete True
Next myFile
End Sub
------------------L'effacement-----------------
Sub auto_open()
Dim myFso, myFile, myFolder
Set myFso = CreateObject("Scripting.FileSystemObject")
'sélection du dossier à analyser
Set myFolder = myFso.GetFolder("\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\")
'boucle sur tous les fichier du dossier
For Each myFile In myFolder.Files
    'si la date de modification du fichier est antérieure à 3 jours, effacer le fichier
    If DateDiff("d", myFile.DateLastModified, Now) > 2 Then myFile.Delete True
Next myFile
End Sub
-----------------la création des fichiers-----------------
Sub creation()
Dim Chemin, fname As String 'jour
Chemin = "\Ds-srv-hector\commun\DPAPH\Service Tarification\Sauvegarde temps réel\" 
debut:
Start = Timer
intervalle = 60
Do While Timer < Start + intervalle
DoEvents ' laisse les autres applications
Loop
fname = "test- " & Day(Date) & "-" & Month(Date) & "-" & Year(Date) & " - " & Hour(Time) & "H" & Minute(Time) & "m" & Second(Time) & "s" & ".xls"
ActiveWorkbook.SaveCopyAs Chemin & fname
GoTo debut
End Sub

Allez bonne soirée et a plus certainement

"macro excel création et effacement auto&quot

22 réponses

Votre réponse

Discussions similaires

Newsletters