Philippe Tulliez

[Actualité] VBA Comment lister les sous-dossiers d'un répertoire parent avec critère à l'aide de la fonction Dir

Noter ce billet

par

, 30/04/2023 à 07h59 (4103 Affichages)

Introduction
Il nous arrive d'avoir besoin d'obtenir la liste des sous-dossiers d'un répertoire parent avec en plus un critère de recherche sur le nom comme

commence par
se termine par
contient

Il existe plusieurs méthodes pour le faire et entre autres la fonction Dir. J'ai écrit une fonction générique basée sur cette fonction et qui renvoie une liste sous forme de tableau.
C'est cette procédure que je publie et commente dans ce billet.

Code de la procédure

Code VBA :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Function GetFolderList(ByVal LookupFolder As String, Optional Criteria As String)
  ' Renvoie une liste des sous-dossier présents dans le répertoire défini pas l'argument LookupFolder
  ' Philippe Tulliez (http://www.magicoffice.be)
  ' Arguments
  '   LookupFolder (String) Nom du répertoire complet à parcourir
  '   [Criteria]   (String) Chaîne de caractères
  '                Caractères génériques (*, ?) autorisés
  Dim f As String, c As Integer, t As Variant
  Dim n As String
  n = LookupFolder & Criteria
  f = Dir(n, vbDirectory)
  Do While Len(f)
    If f <> "." And f <> ".." And ((GetAttr(f) And vbDirectory) = vbDirectory) Then
       If c Then ReDim Preserve t(c) Else ReDim t(c)
       t(c) = f: c = c + 1: f = Dir
     Else
       f = Dir
    End If
  Loop
  GetFolderList = t
End Function

Exemple
Voici l'exemple d'une procédure qui invoque la fonction générique GetFolderList et renvoie la liste des sous-répertoires commençant par la lettre e présents dans le répertoire courant du classeur actif (ThisWorkbook).
Pour lister la liste complète des sous-répertoires, il suffit de ne conserver qu'une chaine vide "" de la constante c

Code VBA :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub TestGetFolderList()
  Const c As String = "e*"   ' Critère de recherche
  Dim f As String            ' Répertoire courant
  Dim t As Variant           ' Table des sous-répertoires
  Dim m As String
  f = ThisWorkbook.Path & "\"
  t = GetFolderList(LookupFolder:=f, Filter:=c)
  m = "Répertoire courant :" & vbCrLf & " " & f & vbCrLf & " " & IIf(Len(c), " avec comme critère " & c, "") & vbCrLf
  If IsArray(t) Then
     m = m & Join(t, vbCrLf)
   Else
     m = m & "Pas trouvé"
  End If
  MsgBox m, Title:="Liste des sous-répertoires"
End Sub