1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
| Option Explicit
Sub ProcedurePrincipal()
'Déclaration des variables
Dim Dossier As String
Dim cmpt As Integer '# variable ajouté
'Choix du répertoire :
With Application.FileDialog(msoFileDialogFolderPicker)
'Définit un titre pour la boîte de dialogue
.Title = "Sélectionnez le répertoire de recherche:"
'Affiche la boîte de dialogue
.Show
'Affiche le nom du dossier sélectionné
If .SelectedItems.Count > 0 Then
'MsgBox .SelectedItems(1)
Dossier = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
Else
MsgBox "Aucun répertoire n'a été sélectionné. La procédure va s'arrêter"
Exit Sub
End If
End With
'Message de précaution avant suppression de la feuille "Listing"
If MsgBox("Les informations de la feuille Listing vont être supprimées." & vbCrLf & "Si vous souhaitez les conserver faites une copie avant de poursuivre." & vbCrLf & "Voulez-vous continuer ?", vbYesNo, "Nouveau Listing") = vbYes Then
'# Compte le nombre de sous dossier de départ
cmpt = IIf(InStr(Dossier, "\") > 0, Len(Dossier) - Len(Replace(Dossier, "\", "")) + 1, 1)
'Selection de la feuille de travail
Sheets("Listing").Select
'Appel de la procedure SuppressionDesValeurs
Call SuppressionDesValeurs
'Affectation des libellés de colonnes
Cells(1, 1) = "Chemin complet"
Cells(1, 2) = "Nom du fichier"
Cells(1, 3) = "Repertoire principal"
'Appel de la procédure de listing
Call ListeFichiers(Dossier, cmpt)
' Mise en forme des entêtes de colonnes
'Numérotation des différents niveaux des répertoires
Dim j As Long
Dim NumColonne As Long
For j = 4 To 100
NumColonne = Application.WorksheetFunction.CountA(Columns(j))
If NumColonne > 0 Then Cells(1, j) = "Niveau " & j - 3
Next j
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
With Selection
.Font.Bold = True
.Interior.ColorIndex = 44
.HorizontalAlignment = xlCenter
End With
Columns("A:IV").AutoFit
MsgBox "Le listing du répertoire :" & vbCrLf & Dossier & vbCrLf & " est terminé !!"
Sheets("Listing").Select
End If
End Sub
'Procedure de listing des fichiers
Sub ListeFichiers(Repertoire As String, NbRepRacine As Integer)
'Déclaration des variables
Dim Fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim i As Long
Dim tabSplit() As String
Dim tabIndex As Integer
Dim colonne As Integer
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(Repertoire)
'Récupère le numéro de la dernière ligne vide dans la colonne A.
i = Range("A65536").End(xlUp).Row + 1
'Boucle sur tous les fichiers du répertoire
For Each FileItem In SourceFolder.Files
'Inscrit le chemin complet du fichier
Cells(i, 1) = FileItem.ParentFolder & "\"
'Inscrit le nom du fichier
Cells(i, 2) = FileItem.Name
'Gestion de l'écriture 1 repertoire par colonne
tabSplit = Split(FileItem.ParentFolder, "\")
colonne = 3
For tabIndex = NbRepRacine - 1 To UBound(tabSplit)
Cells(i, colonne) = tabSplit(tabIndex)
colonne = colonne + 1
Next
i = i + 1
Next FileItem
'--- Appel récursif pour lister les fichier dans les sous-répertoires ---.
For Each SubFolder In SourceFolder.SubFolders
Call ListeFichiers(SubFolder.Path, NbRepRacine)
Next SubFolder
End Sub
'Procedure de Suppression des données de la feuille "Listing"
Sub SuppressionDesValeurs()
Cells.Delete
End Sub |
Lister les fichiers dans les dossiers et sous dossiers
Répondre avec citation
ocument and Setting\Nom>tree/C:/Public>liste100101.xls et entrée 
Partager