Chercher les sous-dossiers dans un dossier

Question

Bonjour, 

Voilà mon problème, j'ai actuellement un code qui fait exactement ce que je veux. Il ouvre les fichiers excel un par un d'un dossier et y pioche des informations pour les retranscrire sur un récap excel. Cependant, je vois que dans ce dossier qui contient les fichiers excel existent des sous-dossiers qui contiennent eux-même des fichiers excel et d'autres sous-dossiers encore. D'où ma question : Comment faire pour ouvrir un à un TOUS les fichier excel de ce dossier et des sous-dossiers?

Voici mon code :

Sub Recap()
 
Dim Dossier As Object
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_Dossier = "C:\Users\Jerome.CHARLAT\Desktop\Grilles"
Set système = CreateObject("Scripting.FileSystemObject")
Set Dossier = système.GetFolder(Nom_Dossier)
Set Fichiers = Dossier.Files
Nom_Recap = ThisWorkbook.Name

x = 2
 
For Each Fichier In Fichiers
 
Nom_Fichier = Nom_Dossier & "\" & Fichier.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(Fichier.Name).Activate

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

If Workbooks(Fichier.Name).Sheets(4).Range("B" & i) = "S" Then
    If Workbooks(Fichier.Name).Sheets(4).Range("C" & i).Value >= Workbooks(Fichier.Name).Sheets(4).Range("D" & i).Value Then
        y = y + 1
        With Workbooks(Fichier.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(Fichier.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 = Fichier.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(Fichier.Name).Close False

x = x + 1
 
Next Fichier

Workbooks(Nom_Recap).Sheets(1).Columns("A:DL").EntireColumn.AutoFit

End Sub

Merci d'avance pour votre aide.

Cordialement.

gbinforme · Answer

Bonjour,

Tu devrais avoir la solution dans cette page

Kuartz · Answer

Bonjour,

Je t'avoue que je n'arrive pas à adapter le code... Je crois que ça dépasse mes connaissances... Pourrais-je avoir de l'aide?

Merci beaucoup par avance.

Cordialement.

Kuartz · Answer

J'ai trouvé un code qui commence à presque fonctionner. Sauf que j'ai un soucis.

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

Lorsque le code arrive sur un fichier qui est dans un sous-dossier, il me demande de vérifier que le fichier existe bien car il ne le trouve pas. Et pour cause, il n'y a pas son chemin... Je ne sais pas comment le faire apparaître.

gbinforme · Answer

Bonjour, 

Bon, j'ai travaillé pour rien, mais je te mets tout de même les macros dans le classeur de test :

https://www.dropbox.com/s/0ky9ds3v0jfcxr3/Kuartz.xlsm?dl=0

J'ai découpé ta macro en modules pour que cela fonctionne et j'ai mis un compte rendu final.

Chercher les sous-dossiers dans un dossier

4 réponses

Discussions similaires

Newsletters