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
| Sub FileList()
Dim Chem As String, Rep As String, Fich As String, FichComp
Dim nLig As Integer, i As Integer
Dim tablo() As String
Chem = "C:\Documents and Settings\" 'Path initial
ReDim tablo(1)
tablo(0) = Chem: i = 1
'Recherche les répertoires (1er niveau) dans Chem
Rep = Dir(Chem, vbDirectory)
Do While Rep <> ""
If Rep <> "." And Rep <> ".." Then
If (GetAttr(Chem & Rep) And vbDirectory) = vbDirectory Then
ReDim Preserve tablo(i + 1)
tablo(i) = Chem & Rep
i = i + 1
End If
End If
Rep = Dir
Loop
'Pour Chaque répertoire, lister les fichiers répondant au critère DOC_DOCX_XLS_JPG
With Sheets("Feuil2") 'à adapter
For i = 0 To UBound(tablo)
Fich = Dir(tablo(i) & "\", vbNormal)
Do While Fich <> ""
If InStr(".DOC_DOCX_.XLS_.MBD_.JPG_.PDF", UCase(Right(Fich, 4))) > 0 Then 'à adapter selon les extensions de fichier à chercher
nLig = .Cells(Rows.Count, 2).End(xlUp).Row + 1
.Range("A" & nLig).Value = tablo(i)
.Range("B" & nLig).Value = Fich
End If
Fich = Dir
Loop
Next i
For i = 2 To nLig
Rep = .Range("A" & i).Value
Fich = .Range("B" & i).Value
FichComp = Rep & "/" & Fich
.Range("C" & i).Value = FileDateTime(FichComp)
.Hyperlinks.Add anchor:=.Range("D" & i), Address:=FichComp
Next i
End With
End Sub |
Partager