Option Explicit
'*****************************************************************************************************
' ___ _ _______ __ _ ____ _ _ _______ ___ _ _ _ ___ _ _.
' // \\ /\\ // // \\ // // // // // // \\ // // // // \\ //| //
' //___// //__\ // //__// // // //__// // // // // // // // // // | //
' // // \\ // // \\ // // // \\ // // // // // // // // // | //
'// // // // // // // //___ // \\ // \\__// //__// //___ \\__// // |//
'****************************************************************************************************
'Fonction de listage de dossier dans une récursivité alternative (intra fonction)avec critères utilisant LA FONCTION DIR DE VBA
'-------------------------------------------------------------
'basée sur le même raisonnement que la DirPileListDIR(patricktoulon)
'------------------------------------------------------------
'Auteur: Patricktoulon
'Version DIR Alternative 1.2
'Méthode que j'ai appelé methode Pile :):)(Lecture de la pile de dossier rempli dynamiquement dans ses propres tours dans la collection)
'Date version : 15/03/2026
'Cette fonction utilise une alternative aux appels récursifs d'une fonction
'En effet dans celle ci la recursivité se fait par le do/loop dans le parcours la collection de folder
'Que je rempli tout au long des tours de boucle sur collection tout en supprimant le premier (le dossier en examen) a chaque tours
'Une alternative interessante a la recursivité classique utilisée en vba(Par rappel successifs de la fonction elle même)
'On a pas besoin de Variables statiques ou variables transportée a chaque tours
'On peu considérer que la encore diviser pour mieux règner reste un dogme qui se verifie
'Puisque chaque tour de do/loop supprime le dossier passé en revue et chaque tours passe en revvue seulement ses sous dossiers
'------------------------------------------------------------------------------------------------
'Un seul inconvénient ici c'est que les dossiers de sont pas classé dans l'ordre
'Il faut faire un tri (voir mes méthodes de tri le quicksort dans les ressources )
'------------------------------------------------------------------------------------------------
'Exemple d'utilisation
' 1° Liste complete de l'arborescence des dossiers
' x= DirPileFolderListDIR(chemin du dossier maitre)
'
' 2° Liste complete de l'arborescence des dossiers contenant une expression dans leur nom
' x= DirPileFolderListDIR(chemin du dossier maitre,"blablabla",true,true)
'
' 3° Liste complete de l'arborescence des dossiers ayant le nom ....
' x= DirPileFolderListDIR(chemin du dossier maitre,nom du dossier,false,true)
'
' 4° Récuperation du chemin complet avec le nom du dossier
' Folder = DirPileFolderListDIR("chemin dossier maitre", "nom du dossier recherché")
'
' 5° Récuperation du chemin complet avec une partie du nom du dossier
' Folder = DirPileFolderListDIR("chemin dossier maitre", "partie nom du dossier recherché")
'
'
'------------------------------------------------------------------------------------------------
'Autrement dit la fonction renvoie un variant/string ou variant()
'------------------------------------------------------------------------------------------------
Sub clear_cell()
Cells.Clear
End Sub
Sub tri()
With ActiveWorkbook.Worksheets("Feuil1")
.Sort.SortFields.Clear
.Range("A1:A2491").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo
End With
End Sub
Sub testList()
clear_cell
'Test de récupération complete de la liste des dossier (et leurs sous dossiers)
Dim ListeFolder
ListeFolder = DirPileFolderListDIR("C:\Users\patricktoulon\Desktop\Dossier général")
If IsArray(ListeFolder) Then
MsgBox UBound(ListeFolder) & "dossier(s) trouvé(s)"
Cells(1, 1).Resize(UBound(ListeFolder), 1) = Application.Transpose(ListeFolder)
tri
End If
End Sub
Sub Test_Liste_2()
clear_cell
'Test de récupération de la liste des dossiers ayant "€" dans leur noms
Dim ListeFolder
ListeFolder = DirPileFolderListDIR("C:\Users\patricktoulon\Desktop\Dossier général", "€", True, True)
If IsArray(ListeFolder) Then
MsgBox UBound(ListeFolder) & "dossiers trouvés"
Cells(1, 1).Resize(UBound(ListeFolder), 1) = Application.Transpose(ListeFolder)
tri
End If
End Sub
Sub Test_Liste_3()
clear_cell
'Test de récupération de la liste des dossiers ayant "184€" dans leur noms
Dim ListeFolder
ListeFolder = DirPileFolderListDIR("C:\Users\patricktoulon\Desktop\Dossier général", "148€", True, True)
If IsArray(ListeFolder) Then
MsgBox UBound(ListeFolder) & "dossiers trouvés"
Cells(1, 1).Resize(UBound(ListeFolder), 1) = Application.Transpose(ListeFolder)
tri
End If
End Sub
Sub Test_Liste_4()
clear_cell
'Test de récupération de la liste des dossiers ayant pour nom "Lien"
Dim ListeFolder
ListeFolder = DirPileFolderListDIR("C:\Users\patricktoulon\Desktop\Dossier général", "Lien", , True)
If IsArray(ListeFolder) Then
MsgBox UBound(ListeFolder) & "dossiers trouvés"
Cells(1, 1).Resize(UBound(ListeFolder), 1) = Application.Transpose(ListeFolder)
tri
End If
End Sub
Sub cherche_un_dossier1()
'Test de récupération d'un dossier en particulier par son nom
Dim Folder
Folder = DirPileFolderListDIR("C:\Users\patricktoulon\Desktop\Dossier général", "Machin 148€ 150m @2020 DpJ 154€t")
If Folder <> "" Then MsgBox Folder
End Sub
Sub cherche_un_dossier2()
'Test de récupération d'un dossier en particulier avec une partie du nom
Dim Folder
Folder = DirPileFolderListDIR("C:\Users\patricktoulon\Desktop\Dossier général", "@2020 DpJ 154€t", True)
If Folder <> "" Then MsgBox Folder
End Sub
Function DirPileFolderListDIR(dossier As String, Optional ShearchFolder As String = vbNullString, Optional part As Boolean = False, Optional Listing As Boolean = False) As Variant
Dim ItemVU As String, Foldercollection As Collection, CurrentFolder As String, TbL(), a As Long
ReDim TbL(1 To 1)
Set Foldercollection = New Collection
If ShearchFolder = vbNullString Then ShearchFolder = "*": part = True: Listing = True 'forcera le like a passer si searchfolder est videet listera tout
If Right(dossier, 1) <> "\" Then dossier = dossier & "\"
Foldercollection.Add dossier
Do While Foldercollection.Count > 0
CurrentFolder = Foldercollection(1)
Foldercollection.Remove 1
On Error Resume Next
ItemVU = Dir(CurrentFolder, vbDirectory)
If Err.Number <> 0 Then Err.Clear: GoTo NextFolder
Do Until ItemVU = vbNullString
If Left(ItemVU, 1) <> "." Then
If (GetAttr(CurrentFolder & ItemVU) And vbDirectory) = vbDirectory Then
'si une des deux condition passe
If part = False And ItemVU = ShearchFolder Or part = True And " " & ItemVU & " " Like "*" & ShearchFolder & "*" Then
'si listing=false on prend le premier est on sort
If Listing = False Then DirPileFolderListDIR = CurrentFolder & ItemVU & "\": Exit Function
'on continue si on est pas sorti
a = a + 1: ReDim Preserve TbL(1 To a): TbL(a) = CurrentFolder & ItemVU & "\"
End If
'on continue a empiler les dosier dans la collection pour qu'il soient examiné
Foldercollection.Add CurrentFolder & ItemVU & "\"
End If
End If
ItemVU = Dir()
Loop
NextFolder:
Loop
On Error GoTo 0
If Listing = True Then
If a > 0 Then DirPileFolderListDIR = TbL
End If
End Function