Option Explicit
Option Compare Text
Sub MainStatic()
Application.ScreenUpdating = False
Dim F1 As Worksheet
Dim DossierRacine As String
Dim DossierCherche As String
Dim i As Long
' Changement
Dim Resultats As Collection
Set F1 = Worksheets(ActiveSheet.Name)
' Changement
' Maintenant en static dans une fonction (Function) et plus une procédure (Sub)
' Création de l'objet UNE SEULE FOIS pour tout le programme (Gain de vitesse)
' (Ceci est maintenant géré automatiquement par la fonction statique)
DossierRacine = F1.Cells(1, 1).Value
DossierCherche = F1.Cells(20, 1).Value
' Nettoyage de la zone
F1.Range(F1.Cells(1, 2), F1.Cells(100, 2)).Clear
' Ancienne version
' Lancement de la recherche en passant l'objet Fso
' Resultats, Fso inclus dans la procédure.
' Call TrouverTousLesDossiers(DossierRacine, DossierCherche, Resultats, Fso)
' Changement
' ---------------------------------------------------------
' APPEL DE LA FONCTION OPTIMISÉE (STATIC)
' Le 3ème argument "True" est l'indice de démarrage (Initialisation)
' ---------------------------------------------------------
Set Resultats = TrouverTousLesDossiers(DossierRacine, DossierCherche, True)
' Inchangé
' --- RESTITUTION (Identique) ---
' --- GESTION DES RÉSULTATS AVEC LIENS ---
If Resultats.Count = 0 Then
F1.Cells(1, 2).Value = "Non trouvé"
F1.Cells(1, 2).Interior.Color = vbRed
ElseIf Resultats.Count = 1 Then
F1.Hyperlinks.Add Anchor:=F1.Cells(1, 2), Address:=Resultats(1), TextToDisplay:=Resultats(1)
F1.Cells(1, 2).Interior.Color = vbGreen
Shell "explorer.exe " & Chr(34) & Resultats(1) & Chr(34), vbNormalFocus
Else
F1.Cells(1, 2).Value = "Il y a " & Resultats.Count & " dossiers identiques :"
F1.Cells(1, 2).Interior.Color = vbYellow
F1.Cells(1, 2).Font.Bold = True
For i = 1 To Resultats.Count
F1.Hyperlinks.Add Anchor:=F1.Cells(i + 1, 2), Address:=Resultats(i), TextToDisplay:=Resultats(i)
F1.Cells(i + 1, 2).Interior.Color = RGB(220, 240, 220)
If i = 1 Then Shell "explorer.exe " & Chr(34) & Resultats(1) & Chr(34), vbNormalFocus
Next i
End If
F1.Columns("B").AutoFit
Application.ScreenUpdating = True
End Sub
' ---------------------------------------------------------
' FONCTION RECURSIVE STATIQUE (ULTRA RAPIDE)
' ---------------------------------------------------------
Function TrouverTousLesDossiers(DossierPath As String, NomRecherche As String, _
Optional IsStart As Boolean = False) As Collection
Dim Dossier As Object
Dim SousDossier As Object
' 1 - passe en statique (Astuce @Patricktoulon)
' 1. VARIABLES STATIQUES : Change pas entre les appels
Static Fso As Object ' Créé une seule fois
Static ListeResultats As Collection ' Remplie petit à petit sans passage de paramètre
' 2 - met un indice de démarrage (Astuce @Patricktoulon)
' 2. INDICE DE DÉMARRAGE : Initialisation seulement au 1er appel
If IsStart Then
Set ListeResultats = New Collection
If Fso Is Nothing Then Set Fso = CreateObject("Scripting.FileSystemObject")
End If
' Traitement en cours.
On Error Resume Next
Set Dossier = Fso.GetFolder(DossierPath)
If Err.Number <> 0 Then Exit Function
On Error GoTo 0
For Each SousDossier In Dossier.SubFolders
' Si on trouve, on ajoute à la collection (Rapide, pas de Redim)
If SousDossier.Name = NomRecherche Then
ListeResultats.Add SousDossier.Path
End If
' On continue l'exploration (Récursivité)
' CORRECTION ICI : On rappelle la fonction par son bon nom
TrouverTousLesDossiers SousDossier.Path, NomRecherche, False
Next SousDossier
' 3 - le return opéré qu'a la fin : Passage de la Sub en Fonction (Astuce @Patricktoulon)
' 4. RETURN OPÉRÉ QU'À LA FIN (Quand la première call se termine)
If IsStart Then
Set TrouverTousLesDossiers = ListeResultats
End If
End Function
