Autres Faire une recherche de sous-dossiers Windows (pas de fichiers) dans un dossier précis à partir de son nom contenu dans une cellule

Option Compare Text 'la casse est ignorée
Dim chemin$, fso As Object, a$(), n& 'mémorise les variables

Sub CheminDossierGeneral()
With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Sélectionnez le Dossier Général"
    If .Show = False Then End
    [B10] = .SelectedItems(1) 'stockage en B10
End With
End Sub

Sub CheminsDossiers()
If fso Is Nothing Then
    chemin = [B10]
    If Replace(Dir(chemin, vbDirectory), ".", "") = "" Then MsgBox "Le chemin en B10 n'est pas valide !", 48: Exit Sub
    Set fso = CreateObject("Scripting.FileSystemObject")
End If
CheminsDossiersRecursive chemin
With [A12] '1ère cellule de destination
    If n Then .Resize(n) = Application.Transpose(a)
    .Offset(n).Resize(Rows.Count - n - .Row + 1).ClearContents 'RAZ en dessous
End With
Set fso = Nothing
Erase a: n = 0
End Sub

Sub CheminsDossiersRecursive(NomComplet$)
Dim sf As Object
For Each sf In fso.GetFolder(NomComplet).SubFolders
    If InStr(sf.Name, "€") Then
        ReDim Preserve a(n)
        a(n) = sf.Path
        n = n + 1
    End If
    CheminsDossiersRecursive sf.Path
Next sf
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [A12].Resize(Rows.Count - 11), Me.UsedRange) Is Nothing Then Exit Sub
Cancel = True
If Replace(Dir(Target, vbDirectory), ".", "") = "" Then MsgBox "Le chemin n'est pas valide !", 48: Exit Sub
Shell "explorer.exe """ & Target & """", vbNormalFocus 'ouvre le dossier
End Sub