Microsoft 365 Résolu [VBA] Suppression de sous-dossiers et dossiers vides

ralph45

ralph45

XLDnaute Impliqué
Bonjour la communauté ED,

En cherchant sur ce forum et chez feu JBoisgontier, je n'ai pas trouvé de solution exacte à mon questionnement :
comment supprimer de façon automatique les sous-dossiers et les dossiers vides d'un emplacement précis ?
Difficile de joindre un fichier-exemple dans ce contexte... mais je vais essayer d'être explicite.

Exemple & spécificités

sous C:\Users\ralph45\Documents\

--> Supprimer en arborescence ascendante le.s dossier.s vide.s :

1° le dossier-père a "x" dossiers-fils dont 4 vides , ne supprimer que ce.s dossier.s-fils
2° le dossier-père ne doit être supprimé que si le.s dossier-fils est/sont vide.s.
3° et une boucle qui remonte l'arborescence jusqu'à "C:\Users\ralph45\Documents\"

NB Cerise sur le gâteau (de Noël et pas une bûche), message informatif de "x" dossier.s supprimé.s

En attendant vos suggestions, je vous adresse mes meilleurs vœux de fêtes et de fin d'année...
Et surtout, abusez de tout avec modération ! 🥳

ralph45
 
Trier par date Trier par votes
Dranreb

Dranreb

XLDnaute Barbatruc
Bonjour.
Essayez ça :
VB: 
Option Explicit
Sub SupprimerSsDos()
   Dim FSO As New Scripting.FileSystemObject, N As Long
   If NbSDosSuppr(FSO.GetFolder("C:\Users\ralph45\Documents")) = 0 Then
      MsgBox "Aucun sous dossier n'a été supprimé.", vbInformation
      End If
   End Sub
Function NbSDosSuppr(ByVal Fdr As Folder) As Long
   Dim SFdr As Folder
   For Each SFdr In Fdr.SubFolders
      NbSDosSuppr = NbSDosSuppr + NbSDosSuppr(SFdr)
      If SFdr.Files.Count + SFdr.SubFolders.Count = 0 Then
         SFdr.Delete
         NbSDosSuppr = NbSDosSuppr + 1
         End If
      Next SFdr
   If NbSDosSuppr > 0 Then MsgBox NbSDosSuppr & " dossiers supprimés dans :" _
      & vbLf & Fdr.Name, vbInformation
   End Function
Référence "Microsoft Scripting Runtime" cochée, évidemment.
 
Dernière édition:
Vote positif 0 Vote négatif
M12

M12

XLDnaute Accro
ralph45 à dit:
Bonjour la communauté ED,

En cherchant sur ce forum et chez feu JBoisgontier, je n'ai pas trouvé de solution exacte à mon questionnement :
comment supprimer de façon automatique les sous-dossiers et les dossiers vides d'un emplacement précis ?
Difficile de joindre un fichier-exemple dans ce contexte... mais je vais essayer d'être explicite.

Exemple & spécificités

sous C:\Users\ralph45\Documents\

--> Supprimer en arborescence ascendante le.s dossier.s vide.s :

1° le dossier-père a "x" dossiers-fils dont 4 vides , ne supprimer que ce.s dossier.s-fils
2° le dossier-père ne doit être supprimé que si le.s dossier-fils est/sont vide.s.
3° et une boucle qui remonte l'arborescence jusqu'à "C:\Users\ralph45\Documents\"

NB Cerise sur le gâteau (de Noël et pas une bûche), message informatif de "x" dossier.s supprimé.s

En attendant vos suggestions, je vous adresse mes meilleurs vœux de fêtes et de fin d'année...
Et surtout, abusez de tout avec modération ! 🥳

ralph45
Cliquez pour agrandir...
Bonjour,
Un test
VB: 
Sub SuppDoss()
  Dim FSO As Object, Dossier As String, Doss As Object, D1 As Object, OK As Boolean
  Dossier = "C:\Users\ralph45\Documents"
  Set FSO = CreateObject("Scripting.FileSystemObject")
  Set Doss = FSO.getfolder(Dossier)
  For Each D1 In Doss.subfolders
    If D1.subfolders.Count + D1.Files.Count = 0 Then
      OK = True
      If OK = True Then D1.Delete True
    Else
      OK = False
    End If
  Next D1
 
End Sub
 
Vote positif 0 Vote négatif
ralph45

ralph45

XLDnaute Impliqué
Bonjour ces messieurs et merci de votre réactivité !

Je vais prendre et adapter le code VBA de @Dranreb car il correspond à une gestion totale de suppressions des dossiers, mais je désactiverai la notion de messages, car il m'aurait fallu un nombre total récapitulatif de dossiers supprimés et non un message pour chaque dossier. Mais tant mieux, on gagne en temps de reprise en main.
@M12 : ton code est incomplet, car il me laisse un dossier-père vide et un dossier-fils vide (ou sous-dossier vide). Par contre, il supprime bien les dossiers vides n'ayant pas de sous-dossiers.

Encore merci !
 
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Une version avec possibilité d'enlever confirmation et message :
VB: 
Option Explicit
Sub SupprimerSsDos()
   Dim FSO As New Scripting.FileSystemObject, N As Long
   N = NbSDosSuppr(FSO.GetFolder("C:\Users\ralph45\Documents"), Toujours:=True)
   Select Case N
      Case Is > 1: MsgBox " sous dossiers ont été supprimés.", vbInformation
      Case 1: MsgBox "Un sous dossier a été supprimé.", vbInformation
      Case Else: MsgBox "Aucun sous dossier n'a été supprimé.", vbInformation
      End Select
   End Sub
Function NbSDosSuppr(ByVal Fdr As Folder, Optional ByVal Toujours As Boolean) As Long
   Dim SFdr As Folder, Supprimer As Boolean
   On Error GoTo E
   For Each SFdr In Fdr.SubFolders
      NbSDosSuppr = NbSDosSuppr + NbSDosSuppr(SFdr, Toujours)
      If SFdr.Files.Count + SFdr.SubFolders.Count = 0 Then
         If Toujours Then
            Supprimer = True
         Else
            Supprimer = MsgBox("""" & SFdr.Name & """ vide." _
               & vbLf & "Fdr.Path = """ & Fdr.Path & """." _
               & vbLf & "À supprimer ?", vbYesNo, "NbSDosSuppr(Fdr)") = vbYes
            End If
         If Supprimer Then
            SFdr.Delete
            NbSDosSuppr = NbSDosSuppr + 1
            End If
         End If
      Next SFdr
   If Toujours Then Exit Function
   If NbSDosSuppr > 0 Then MsgBox NbSDosSuppr & " dossiers supprimés dans :" _
      & vbLf & Fdr.Name, vbInformation
   Exit Function
E: Select Case MsgBox("Erreur " & Err _
      & vbLf & "Fdr.Path = """ & Fdr.Path & """." _
      & vbLf & Err.Description, vbExclamation + vbAbortRetryIgnore, "NbSDosSuppr(Fdr)")
      Case vbRetry: On Error GoTo 0: Resume
      Case vbIgnore: Resume Next
      End Select
   End Function
À tester prudemment …
 
Vote positif 0 Vote négatif
ralph45

ralph45

XLDnaute Impliqué
Dranreb à dit:
Une version avec possibilité d'enlever confirmation et message :
VB: 
Option Explicit
Sub SupprimerSsDos()
   Dim FSO As New Scripting.FileSystemObject, N As Long
   N = NbSDosSuppr(FSO.GetFolder("C:\Users\ralph45\Documents"), Toujours:=True)
   Select Case N
      Case Is > 1: MsgBox " sous dossiers ont été supprimés.", vbInformation
      Case 1: MsgBox "Un sous dossier a été supprimé.", vbInformation
      Case Else: MsgBox "Aucun sous dossier n'a été supprimé.", vbInformation
      End Select
   End Sub
Function NbSDosSuppr(ByVal Fdr As Folder, Optional ByVal Toujours As Boolean) As Long
   Dim SFdr As Folder, Supprimer As Boolean
   On Error GoTo E
   For Each SFdr In Fdr.SubFolders
      NbSDosSuppr = NbSDosSuppr + NbSDosSuppr(SFdr, Toujours)
      If SFdr.Files.Count + SFdr.SubFolders.Count = 0 Then
         If Toujours Then
            Supprimer = True
         Else
            Supprimer = MsgBox("""" & SFdr.Name & """ vide." _
               & vbLf & "Fdr.Path = """ & Fdr.Path & """." _
               & vbLf & "À supprimer ?", vbYesNo, "NbSDosSuppr(Fdr)") = vbYes
            End If
         If Supprimer Then
            SFdr.Delete
            NbSDosSuppr = NbSDosSuppr + 1
            End If
         End If
      Next SFdr
   If Toujours Then Exit Function
   If NbSDosSuppr > 0 Then MsgBox NbSDosSuppr & " dossiers supprimés dans :" _
      & vbLf & Fdr.Name, vbInformation
   Exit Function
E: Select Case MsgBox("Erreur " & Err _
      & vbLf & "Fdr.Path = """ & Fdr.Path & """." _
      & vbLf & Err.Description, vbExclamation + vbAbortRetryIgnore, "NbSDosSuppr(Fdr)")
      Case vbRetry: On Error GoTo 0: Resume
      Case vbIgnore: Resume Next
      End Select
   End Function
À tester prudemment …
Cliquez pour agrandir...

Super @Dranreb !!

Il manquait juste un petit point :
Case Is > 1: MsgBox " sous dossiers ont été supprimés.", vbInformation
-->
Case Is > 1: MsgBox N & " sous dossiers ont été supprimés.", vbInformation

👍
 
Vote positif 0 Vote négatif

Discussions similaires

T
  • Question
XL 2010 VAB - Copier les fichiers manquants d'un dossier et de ses sous-dossiers
Réponses
2
Affichages
379
Titi456
T
T
  • Résolu(e)
XL 2010 Bouton - Supprimer photos JPG dans un dossier et ses sous-dossiers
Réponses
9
Affichages
603
Titi456
T
T
  • Résolu(e)
XL 2010 VBA - Bouton pour supprimer les documents d'un dossier et de ses sous-dossiers
Réponses
7
Affichages
599
tchi456
T
ralph45
  • Question
Microsoft 365 [Résolu] VBA | Interdire la saisie de certains caractères dans un TextBox
Réponses
5
Affichages
1 K
ralph45
ralph45
jeanmi
  • Question
XL 2010 Création dossiers et sous dossiers en VBA
Réponses
5
Affichages
3 K
jeanmi
jeanmi
sebbbbb
  • Question
XL 2010 création de dossiers et sous-dossiers selon données a préciser par msgbox
Réponses
5
Affichages
879
sebbbbb
sebbbbb
W
  • Question
XL 2019 VBA création facile de sous-dossier et hyperlien automatique
Réponses
2
Affichages
804
watt3211
W
L
  • Question
XL 2019 Code VBA, chercher un fichier et mettre hyperlink dans cellule correspondante
Réponses
5
Affichages
1 K
laktats
L
A
  • Question
XL 2013 copy de fichier entre 2 sous dossiers VBA
Réponses
2
Affichages
921
adjovi7
A
J
  • Question
VBA: Obtenir le nom des dossiers présents dans un repertoire
Réponses
6
Affichages
2 K
Caillou
C

Membres actuellement en ligne

6 membres et 75 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 719
Messages
2 112 183
Membres
111 455
dernier inscrit
Jacandre