Suppression dossier VBA selon nom

FaridP

XLDnaute Occasionnel
Bonsoir à toutes et à tous,

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.

Farid
 

FaridP

XLDnaute Occasionnel
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.

Encore merci.

Farid
 

zebanx

XLDnaute Accro
Bonjour FaridP, cp4, le forum

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
 

Pièces jointes

  • code supp wbk (date).xlsm
    17.1 KB · Affichages: 10

FaridP

XLDnaute Occasionnel
Bonjour FaridP, cp4, le forum

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
Hello Zebanx, cp4,

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.

Bonne fin de journée,

Farid
 

FaridP

XLDnaute Occasionnel
Salut Zebanx, cp4,

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.

Farid
 
Dernière édition:

Discussions similaires

Réponses
2
Affichages
241

Statistiques des forums

Discussions
311 709
Messages
2 081 756
Membres
101 812
dernier inscrit
trufu