Chercher les sous-dossiers dans un dossier
Fermé
Kuartz
Messages postés
850
Date d'inscription
vendredi 13 février 2015
Statut
Membre
Dernière intervention
15 février 2019
-
24 mai 2016 à 17:23
Kuartz Messages postés 850 Date d'inscription vendredi 13 février 2015 Statut Membre Dernière intervention 15 février 2019 - 27 mai 2016 à 15:55
Kuartz Messages postés 850 Date d'inscription vendredi 13 février 2015 Statut Membre Dernière intervention 15 février 2019 - 27 mai 2016 à 15:55
A voir également:
- Chercher les sous-dossiers dans un dossier
- Téléchargez cette archive (dossier compressé). en extraire tous les fichiers dans un dossier local. quel fichier contient l’expression trouverpix ? ✓ - Forum Windows
- Mettre un mot de passe sur un dossier - Guide
- Dossier appdata - Guide
- Dossier rar - Guide
- Dossier favoris chrome ✓ - Forum Google Chrome
4 réponses
gbinforme
Messages postés
14939
Date d'inscription
lundi 18 octobre 2004
Statut
Contributeur
Dernière intervention
24 juin 2020
4 656
24 mai 2016 à 22:08
24 mai 2016 à 22:08
Bonjour,
Tu devrais avoir la solution dans cette page
Tu devrais avoir la solution dans cette page
Kuartz
Messages postés
850
Date d'inscription
vendredi 13 février 2015
Statut
Membre
Dernière intervention
15 février 2019
59
26 mai 2016 à 10:41
26 mai 2016 à 10:41
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.
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
Messages postés
850
Date d'inscription
vendredi 13 février 2015
Statut
Membre
Dernière intervention
15 février 2019
59
26 mai 2016 à 15:03
26 mai 2016 à 15:03
J'ai trouvé un code qui commence à presque fonctionner. Sauf que j'ai un soucis.
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.
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.
Kuartz
Messages postés
850
Date d'inscription
vendredi 13 février 2015
Statut
Membre
Dernière intervention
15 février 2019
59
26 mai 2016 à 16:27
26 mai 2016 à 16:27
Sujet résolu, j'ai trouvé la solution. Code final :
Merci beaucoup à gbinforme pour ton aide !
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 !
gbinforme
Messages postés
14939
Date d'inscription
lundi 18 octobre 2004
Statut
Contributeur
Dernière intervention
24 juin 2020
4 656
26 mai 2016 à 18:08
26 mai 2016 à 18:08
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.
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.
Kuartz
Messages postés
850
Date d'inscription
vendredi 13 février 2015
Statut
Membre
Dernière intervention
15 février 2019
59
27 mai 2016 à 15:55
27 mai 2016 à 15:55
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.
Tu n'as pas travaillé pour rien, je vais lire ce que tu as fait pour comparer.
Cordialement.