Chercher les sous-dossiers dans un dossier

Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   -  
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   -
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.
A voir également:

4 réponses

Réponse 1 / 4
gbinforme Messages postés 14946 Date d'inscription   Statut Contributeur Dernière intervention   4 724
 
Bonjour,

Tu devrais avoir la solution dans cette page
0
Réponse 2 / 4
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   61
 
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.
0
Réponse 3 / 4
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   61
 
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.
0
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   61
 
Sujet résolu, j'ai trouvé la solution. Code final : 

Sub Recap_S()
  Application.ScreenUpdating = False
  racine = ChoixDossier()
  If racine = "" Then Exit Sub
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dossier_racine = fs.GetFolder(racine)
  Lit_dossier dossier_racine, 1, 2
End Sub

Sub Lit_dossier(ByRef dossier, ByVal niveau, ByRef x)

Dim système As Object
Dim Nom_Fichier As String
Dim Nom_Recap As String
Dim y As Long
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
 

Nom_Recap = ThisWorkbook.Name


For Each f In dossier.Files


Nom_Fichier = f.Path
Workbooks.Open Filename:=Nom_Fichier
 
 
y = 0

 
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 f

  For Each d In dossier.SubFolders
     Lit_dossier d, niveau + 1, x
  Next
  
Workbooks(Nom_Recap).Sheets(1).Range("A1").Value = "Récap "
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


Merci beaucoup à gbinforme pour ton aide !
0
Réponse 4 / 4
gbinforme Messages postés 14946 Date d'inscription   Statut Contributeur Dernière intervention   4 724
 
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.
0
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   61
 
Merci beaucoup pour le temps passé à m'aider.

Tu n'as pas travaillé pour rien, je vais lire ce que tu as fait pour comparer.

Cordialement.
0

Discussions similaires

Extraire le contenu de plusieurs fichiers
politicus -
Syl_tls1 -

11 réponses