Recherche dossier

Z = Dir("*", vbDirectory)
While Z <> ""
   If GetAttr(Z) = vbDirectory And Z > ".." Then
      ...
      End If
   Z = Dir
   Wend

Public ListeDoss() As String

Sub InitDoss()
Dim FSO, Lecteur
    ReDim ListeDoss(1 To 1)
    Set FSO = CreateObject("Scripting.FileSystemObject")
    'For Each Lecteur In FSO.Drives
    '    If UBound(ListeDoss) > 1 Then ReDim Preserve ListeDoss(1 To UBound(ListeDoss) + 1)
    '    ListeDoss(UBound(ListeDoss)) = Lecteur.DriveLetter & ":\"
    '    ChercheDossiers (Lecteur.DriveLetter & ":\")
    'Next
    ChercheDossiers ("C:\")
    For i = 1 To UBound(ListeDoss)
        Range("A" & i).Value = ListeDoss(i)
    Next i
End Sub


Sub ChercheDossiers(AdrDoss As String)
Dim FSO, Doss, SousDoss
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Doss = FSO.GetFolder(AdrDoss)
    On Error GoTo Fin
    For Each SousDoss In Doss.SubFolders
        ReDim Preserve ListeDoss(1 To UBound(ListeDoss) + 1)
        ListeDoss(UBound(ListeDoss)) = SousDoss.Path
        ChercheDossiers (SousDoss.Path)
    Next
    On Error GoTo 0
Fin:
End Sub

Sub InitDoss()
Dim FSO, Lecteur
    ReDim ListeDoss(1 To 1)
    Set FSO = CreateObject("Scripting.FileSystemObject")
    t = Timer
    'For Each Lecteur In FSO.Drives
    '    If UBound(ListeDoss) > 1 Then ReDim Preserve ListeDoss(1 To UBound(ListeDoss) + 1)
    '    ListeDoss(UBound(ListeDoss)) = Lecteur.DriveLetter & ":\"
    '    ChercheDossiers (Lecteur.DriveLetter & ":\")
    'Next
    ChercheDossiers ("C:\")
    For i = 1 To UBound(ListeDoss)
        Range("D" & i).Value = ListeDoss(i)
    Next i
    MsgBox Timer - t
End Sub

Range("D1:D" & UBound(ListeDoss)) = Application.Transpose(ListeDoss)

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim Doss As String
    If Target.Column = 3 And Target.Count = 1 Then
        If Target.Value <> "" Then
            Cancel = True
            Doss = Dir("C:\Clients\*" & Target.Value & "*", vbDirectory)
            If Doss = "" Then
                MsgBox "Pas de dossier client trouvé"
            Else
                a = Shell("Explorer.exe " & Chr(34) & "C:\Clients\" & Doss & Chr(34), vbMaximizedFocus)
            End If
        End If
    End If
End Sub