Chercher les sous-dossiers dans un dossier

Dim ligne
Sub arborescence()
  Application.ScreenUpdating = False
  racine = ChoixDossier() ' ou un répertoire C:\xxx e.g.
  If racine = "" Then Exit Sub
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dossier_racine = fs.GetFolder(racine)
  ligne = 3
  Lit_dossier dossier_racine, 1
End Sub

Sub Lit_dossier(ByRef dossier, ByVal niveau)

Dim Fichiers As Object
Dim Fichier As Object
Dim Nom_Dossier As String
Dim système As Object
Dim Nom_Fichier As String
Dim Nom_Recap As String
Dim x As Long
Dim y As Long
 

Nom_Recap = ThisWorkbook.Name

x = 2

For Each f In dossier.Files

'______________________________________________________________________________________________________

Nom_Fichier = dossier.Name & "\" & f.Name
Workbooks.Open Filename:=Nom_Fichier
 
 
y = 0

Dim i As Long
Dim r As Long
Dim plage As Range
Dim TITRE As Boolean
Dim plage2 As Range
Dim j As Long
Dim k As Long

 
Workbooks(f.Name).Activate

DL = Workbooks(f.Name).Sheets(4).Cells(Application.Rows.Count, 1).End(xlUp).Row
DC = Workbooks(f.Name).Sheets(4).Cells(1, Application.Columns.Count).End(xlToLeft).Column
 
For i = 1 To DL

If Workbooks(f.Name).Sheets(4).Range("B" & i) = "S" Then
    If Workbooks(f.Name).Sheets(4).Range("C" & i).Value >= Workbooks(f.Name).Sheets(4).Range("D" & i).Value Then
        y = y + 1
        With Workbooks(f.Name).Sheets(4)
            Set plage = .Range(.Cells(i, 1), .Cells(i, DC))
            plage.Copy
        End With
        With Workbooks(Nom_Recap).Sheets(1)
            .Cells(x + 1, 1).PasteSpecial Paste:=xlPasteValues
        End With
        x = x + 1
        TITRE = True
    End If
End If
    
Next i
 
If TITRE = True Then
    With Workbooks(f.Name).Sheets(4)
        Set plage = .Range(.Cells(1, 7), .Cells(1, DC))
        plage.Copy
    End With
    With Workbooks(Nom_Recap).Sheets(1)
        .Cells(x - y, 7).PasteSpecial Paste:=xlPasteValues
        .Cells(x - y, 1).Value = f.Name
        .Cells(x - y, 1).Font.Bold = True
        Set plage2 = .Range(.Cells(x - y, 1), .Cells(x + 1, DC))
        plage2.Borders(xlEdgeTop).Weight = xlMedium
    End With
End If

TITRE = False
 
Workbooks(f.Name).Close False

x = x + 1



'_____________________________________________________________________________________________________


Next
  For Each d In dossier.SubFolders
     Lit_dossier d, niveau + 1
  Next
End Sub

Function ChoixDossier()
  If Val(Application.Version) >= 10 Then
    With Application.FileDialog(msoFileDialogFolderPicker)
     .InitialFileName = ActiveWorkbook.Path & "\"
     .Show
     If .SelectedItems.Count > 0 Then
       ChoixDossier = .SelectedItems(1)
     Else
       ChoixDossier = ""
     End If
   End With
  Else
     ChoixDossier = InputBox("Répertoire?")
   End If
End Function