chandler282
XLDnaute Nouveau
Bonjour,
Je viens vers vous pour un petit coup de main.
En effet, j'ai trouvé une macro qui fonctionne plutôt bien mais que je souhaiterai améliorer en l'automatisant encore un peu plus.
En gros, on clic, on sélectionne le dossier parent, la macro scanne tous les dossiers à partir de là où elle se trouve et récupère l'ensemble des noms des dossiers et des fichiers en aval.
Jusque là c'est super.
Aujourd'hui j'aimerai faire exactement la même chose mais sans avoir besoin de sélectionner le dossier. Je clic et elle scanne automatiquement le dossier parent de là où le fichier se trouve. (Éventuellement une deuxième option pour qu'elle scanne seulement le dossier où le fichier se trouve sans remonter ni redescendre)
D'avance merci pour votre aide,
Bonne fin de journée
Nom de la feuille pour faire le test : "ARBORESCENCE"
-----------------------------------------------------------------------------
Dim ligne
Sub arborescenceRepertoire()
Application.Calculation = xlManual
racine = ChoixDossier() ' ou un répertoire C:\xxx e.g.
If racine = "" Then Exit Sub
Sheets("ARBORESCENCE").Activate
Range("b:d").ClearContents
Range("b1:d60000").EntireRow.Hidden = False
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 oFile
Dim CheminDuFichier As String
Application.ScreenUpdating = False
Cells(ligne, 2) = String(0 * (niveau - 1), " ") & Dossier.Name
ligne = ligne + 1
For Each d In Dossier.SubFolders
Lit_dossier d, niveau + 1
For Each oFile In d.Files
Cells(ligne, 3).Value = oFile.Name
CheminDuFichier = d & "\" & oFile.Name
ligne = ligne + 1
Next oFile
Next d
Application.ScreenUpdating = True
Columns(2).EntireColumn.AutoFit
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
Application.DisplayAlerts = False
ChoixDossier = InputBox("Répertoire?")
Application.DisplayAlerts = True
End If
End Function
Je viens vers vous pour un petit coup de main.
En effet, j'ai trouvé une macro qui fonctionne plutôt bien mais que je souhaiterai améliorer en l'automatisant encore un peu plus.
En gros, on clic, on sélectionne le dossier parent, la macro scanne tous les dossiers à partir de là où elle se trouve et récupère l'ensemble des noms des dossiers et des fichiers en aval.
Jusque là c'est super.
Aujourd'hui j'aimerai faire exactement la même chose mais sans avoir besoin de sélectionner le dossier. Je clic et elle scanne automatiquement le dossier parent de là où le fichier se trouve. (Éventuellement une deuxième option pour qu'elle scanne seulement le dossier où le fichier se trouve sans remonter ni redescendre)
D'avance merci pour votre aide,
Bonne fin de journée
Nom de la feuille pour faire le test : "ARBORESCENCE"
-----------------------------------------------------------------------------
Dim ligne
Sub arborescenceRepertoire()
Application.Calculation = xlManual
racine = ChoixDossier() ' ou un répertoire C:\xxx e.g.
If racine = "" Then Exit Sub
Sheets("ARBORESCENCE").Activate
Range("b:d").ClearContents
Range("b1:d60000").EntireRow.Hidden = False
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 oFile
Dim CheminDuFichier As String
Application.ScreenUpdating = False
Cells(ligne, 2) = String(0 * (niveau - 1), " ") & Dossier.Name
ligne = ligne + 1
For Each d In Dossier.SubFolders
Lit_dossier d, niveau + 1
For Each oFile In d.Files
Cells(ligne, 3).Value = oFile.Name
CheminDuFichier = d & "\" & oFile.Name
ligne = ligne + 1
Next oFile
Next d
Application.ScreenUpdating = True
Columns(2).EntireColumn.AutoFit
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
Application.DisplayAlerts = False
ChoixDossier = InputBox("Répertoire?")
Application.DisplayAlerts = True
End If
End Function