Je dois supprimer des dossiers nommés par date au format AAAAMMJJ (ex. : 20181221) dont le nom est antérieur à la date du jour -15.
Ces dossiers se trouvent dans le répertoire : X:\Extractions.
J'ai essayé d'adapter un code récupéré mais déjà sur la liste des répertoires celui du jour est le premier à apparaître alors qu'il devrait être exclu :
Code:
Sub ChercherRépertoire()
Dim DateJour As String
DateJour = Right(Date, 4) & Mid(Date, 4, 2) & Left(Date, 2)
MsgBox DateJour
MyPath = "X:\Extractions\"
MyName = Dir(MyPath, vbDirectory)
Do While MyName <> ""
' Ignore le répertoire courant et le répertoire contenant le répertoire courant
If MyName <> "." And MyName <> ".." Then
' Vérifie que le dossier est antérieur à 15 jours.
If MyName < DateJour - 15 Then
MsgBox MyName
End If '
End If
MyName = Dir ' Extrait l'entrée suivante
Loop
End Sub
Je ne parviens pas à passer à l'étape de suppression du dossier car je bloque sur cette partie.
Pourriez-vous me donner un p'tit coup de main ?
Merci à tout le monde, bonne soirée et bon week-end.
J'ai regardé mais ça explique comment trouver des fichiers, pas des dossier or dans mon cas, je dois boucler sur les dossiers d'un répertoire afin de les supprimer si le nom est antérieur à AAAAMMJJ-15.
Ceci étant, j'ai quand même pu y trouver le code pour supprimer les dossiers.
Il ne reste plus qu'à trouver la première partie du code.
Au bas de ce message, j'ai mis un lien vers le site de Jacques Boisgontier, une mine d'or.
Apparemment tu ne l'as pas remarqué.
Consulte cette page, je suis sûr que tu trouveras ton bonheur.
Un essai
Je ne me souviens plus qui avait donné la formule de E2 dans le code mais l'en remercie encore, c'est utile.
Farid, tu feras attention, pas de message d'alerte pour la suppression et tu ne les auras pas dans la corbeille donc si tu n'as pas sauvegardé...
@+
VB:
Sub supprime_wbk_folder_suivantDate()
Dim x&, y&
Set classeurMaitre = ActiveWorkbook
dt = Date
'--- choix du folder et des fichiers
MyPath = "X:\Extractions"
ChDir MyPath
nf = Dir("*.xl*")
'--- suppresion de certains fichiers
Do While nf <> ""
On Error Resume Next
If nf <> classeurMaitre.Name Then
x = Left(nf, Len(nf) - 5) '--E1
[A2].Formula = "=TEXT(" & x & ",""0000\/00\/00"")*1" '--E2
y = [A2]
If y < dt - 15 Then
Kill (nf)
End If
End If
nf = Dir
Loop
[A2] = ""
'---E1 : prise en compte du nom complet ("AAAAMMJJ")
'--- E2 : utilisation ponctuelle cellule "A2" pour transformer x en valeur
End Sub
Un essai
Je ne me souviens plus qui avait donné la formule de E2 dans le code mais l'en remercie encore, c'est utile.
Farid, tu feras attention, pas de message d'alerte pour la suppression et tu ne les auras pas dans la corbeille donc si tu n'as pas sauvegardé...
@+
VB:
Sub supprime_wbk_folder_suivantDate()
Dim x&, y&
Set classeurMaitre = ActiveWorkbook
dt = Date
'--- choix du folder et des fichiers
MyPath = "X:\Extractions"
ChDir MyPath
nf = Dir("*.xl*")
'--- suppresion de certains fichiers
Do While nf <> ""
On Error Resume Next
If nf <> classeurMaitre.Name Then
x = Left(nf, Len(nf) - 5) '--E1
[A2].Formula = "=TEXT(" & x & ",""0000\/00\/00"")*1" '--E2
y = [A2]
If y < dt - 15 Then
Kill (nf)
End If
End If
nf = Dir
Loop
[A2] = ""
'---E1 : prise en compte du nom complet ("AAAAMMJJ")
'--- E2 : utilisation ponctuelle cellule "A2" pour transformer x en valeur
End Sub
Sauf erreur de ma part, ce code cherche des fichiers Excel or je cherche à supprimer des dossiers complets qui contiennent principalement des fichiers .wav
J'ai essayé d'adapter le code mais je n'y arrive pas.
Je vais continuer de farfouiller sur le site de Boisgontier en espérant y trouver mon bonheur.
En fouillant un peu partout, je suis parvenu à faire exactement ce que je voulais.
Je vous donne le code même si je sais que ce n'est probablement pas propre ni optimisé mais ça fonctionne :
VB:
Private Sub SupDossiers()
Set objFSO = CreateObject("Scripting.FileSystemObject")
RepPrinc = "X:\Extractions\" 'Répertoire contenant les dossiers à supprimer
SousRep = Dir(RepPrinc, vbDirectory) ' Sous répertoire à tester
Dim DateJour As String 'Date du jour
DateJour = Right(Date, 4) & Mid(Date, 4, 2) & Left(Date, 2)
'Parcourir le répertoire principal
Do While SousRep <> ""
If SousRep <> "." And SousRep <> ".." And SousRep <> RepPrinc Then
'Le supprimer si son nom est antérieur à date du jour -15
If SousRep < DateJour - 15 Then objFSO.DeleteFolder (RepPrinc & SousRep), True 'ATTENTION les dossiers et répertoires seront définitivement effacés.
End If
SousRep = Dir
Loop
End Sub
Merci encore pour votre aide et n'hésitez pas à me corriger.