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

Un billet blog de Philippe Tulliez

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

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