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
| Function FeuilleExiste(Feuille) As Boolean
FeuilleExiste = Evaluate("ISREF('" & Feuille & "'!A1)")
End Function
Sub FolderFileList()
With ThisWorkbook.Sheets("LISTES")
Liste = Application.WorksheetFunction.Index(.Range(.Cells(1, 1), .Cells(1, Columns.Count).End(xlToLeft)).Value, 1, 0)
For i = 1 To UBound(Liste)
If FeuilleExiste(Liste(i)) = False Then Sheets.Add , Sheets(Sheets.Count): Sheets(Sheets.Count).Name = Liste(i)
Next
Rep = Application.WorksheetFunction.Index(.Range(.Cells(2, 1), .Cells(2, Columns.Count).End(xlToLeft)).Value, 1, 0)
For i = 1 To UBound(Rep)
Sheets(Liste(i)).Cells(2, 1).CurrentRegion.Clear: chemin$ = Rep(i)
ShName = Liste(i)
F_List = Array(Application.Transpose(.Range(.Cells(3, i), .Cells(Rows.Count, i).End(xlUp)).Value))
MyExtensions = Array("exe", "jpeg", "xlsx", "xls", "pdf") 'Ici on ajoute ou on enlève les extensions
With Sheets(ShName)
.Cells(1) = "'" & String(50, "---") & " STARTING FOLDER : " & " " & Split(chemin, "\")(UBound(Split(chemin, "\")) - 1) & " " & String(50, "---") & " CHEMIN : " & chemin & " " & String(50, "---")
.Rows("1:1").RowHeight = 34
With .Range("A1:F1")
.HorizontalAlignment = xlCenterAcrossSelection: .VerticalAlignment = xlCenter: .Interior.Color = 15921906: .Font.Bold = True: .Font.Size = 14
End With
End With
Entete = Array("DOSSIERS/LIENS", "FICHIERS/LIENS", "DATE DE CREATION", "DATE DE MODIFCATION", "POIDS", "REPERTOIRES")
With Sheets(ShName).Range("A2").Resize(, UBound(Entete) + 1)
.Value = Entete
.HorizontalAlignment = xlCenter: .Interior.ColorIndex = 6: .Font.Bold = True: .Font.Size = 11.5
End With
MyFiles_List chemin, ShName, F_List, MyExtensions
MiseEnForme ShName
Next
End With
End Sub
Sub MyFiles_List(ByVal path As String, ByVal MaFeuille As String, ByVal FolderList As Variant, Extension)
Dim Fichier As String, directory As Variant, dirCollection As New Collection
Fichier = Dir(path, vbDirectory)
Do Until Fichier = vbNullString
If Fichier <> "." And Fichier <> ".." Then
MyFolders = Application.Match(Split(path, "\")(UBound(Split(path, "\")) - 1), FolderList, 0)
If IsError(MyFolders) Then '=> Exclure - If not IsError(MyFolders) Then => inclure
ExtFic = StrReverse(Split(StrReverse(Fichier), ".")(0)): FicOK = Application.Match(ExtFic, Extension, 0)
If Not IsError(FicOK) Then
InfosFichiers path, Fichier, MaFeuille
End If
End If
End If
If Left(Fichier, 1) <> "." And _
(GetAttr(path & Fichier) And vbDirectory) = vbDirectory Then
dirCollection.Add Fichier
End If
Fichier = Dir()
Loop
For Each directory In dirCollection
MyFolders = Application.Match(Split(path & directory & "\", "\")(UBound(Split(path & directory & "\", "\")) - 1), FolderList, 0)
If IsError(MyFolders) Then '=> Exclure - If not IsError(MyFolders) Then => inclure
For y = 0 To 5
With Sheets(MaFeuille).Cells(Rows.Count, y + 1).End(xlUp)(2)
.Value = "---- SubFolder: " & directory & " ----"
.HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter: .ReadingOrder = xlContext: .Font.Size = 11
End With
Next
End If
MyFiles_List path & directory & "\", MaFeuille, FolderList, Extension
Next directory
End Sub
Function InfosFichiers(chemin As String, I_Fichier As String, Feuille As String)
Dim FSO
sep = Application.PathSeparator: Set FSO = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False
With Sheets(Feuille)
ActiveSheet.Hyperlinks.Add Anchor:=.Range("A" & Rows.Count).End(xlUp)(2), Address:= _
chemin, TextToDisplay:=Split(chemin, "\")(UBound(Split(chemin, "\")) - 1)
ActiveSheet.Hyperlinks.Add Anchor:=.Range("B" & Rows.Count).End(xlUp)(2), Address:= _
chemin & sep & I_Fichier, TextToDisplay:=I_Fichier
Set file = FSO.GetFile(chemin & sep & I_Fichier): .Range("C" & Rows.Count).End(xlUp)(2) = Format(file.DateCreated, "dd/mm/yy - hh:mm")
.Range("D" & Rows.Count).End(xlUp)(2) = Format(FileDateTime(chemin & sep & I_Fichier), "dd/mm/yy - hh:mm")
.Range("E" & Rows.Count).End(xlUp)(2) = Round(FileLen(chemin & sep & I_Fichier) / 1024, 2) & " Ko"
.Range("F" & Rows.Count).End(xlUp)(2) = chemin & I_Fichier
End With
Application.ScreenUpdating = True
End Function
Function MiseEnForme(ByVal Feuille As String)
With Sheets(Feuille)
Application.ScreenUpdating = False
.Columns("A:F").AutoFit
With .Range("A2:F" & .Cells(Rows.Count, 1).End(xlUp).Row)
.Cells.FormatConditions.Delete
.FormatConditions.Add Type:=xlTextString, String:="SubFolder:" _
, TextOperator:=xlContains
.FormatConditions(.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Font
.Bold = True
End With
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.Color = 14869218
End With
.FormatConditions(1).StopIfTrue = False
End With
Application.ScreenUpdating = True
End With
End Function |
Envoyé par RyuAutodidacte
Hi unparia,
Répondre avec citation
en n'oubliant pas d'indiquer qu'elle est la solution finale choisie 
.
Partager