Sub avec_Vbdirectory()
Cells.Clear
Dim liste As Variant
liste = DirList(ThisWorkbook.Path & "\MON DOSSIER\")
Cells(1, 1).Resize(UBound(liste), 1).Value = Application.Transpose(liste)
End Sub
Function DirList(Dossier As String, Optional recall As Boolean = False, Optional tbl As Variant) As Variant
Dim ItemVu As String, directory As Variant, SubFolderCollection As Collection, I As Long, A As Long, E As Long
Set SubFolderCollection = New Collection
If Right(Dossier, 1) <> "\" Then Dossier = Dossier & "\"
If recall = False Then ReDim tbl(0) ' si recall on redim un tableau de zero item (pour la creation du tableau)
critère = vbDirectory Or vbHidden Or vbNormal Or vbArchive Or vbReadOnly Or vbSystem Or vbVolume
critère = vbDirectory
On Error Resume Next 'gestion des fichiers dossiers system et interdit ou generant une erreur(PerLog,recycle,etc..)
ItemVu = Dir(Dossier, critère)
If Error.Number = 0 Then ' si pas d'erreur on examine le contenu
'examen du dossier courrant
Do Until ItemVu = vbNullString
If Left(ItemVu, 1) <> "." Then
Debug.Print "|" & Dossier & ItemVu & "|"
If (GetAttr(Dossier & ItemVu) And vbDirectory) = vbDirectory Then
SubFolderCollection.Add ItemVu
Else
A = UBound(tbl) + 1: ReDim Preserve tbl(1 To A): tbl(A) = Dossier & ItemVu
End If
End If
ItemVu = Dir()
Loop
Else
Err.Clear
End If
'examen des sub dossier
For Each subdossier In SubFolderCollection
A = UBound(tbl) + 1: ReDim Preserve tbl(1 To A): tbl(A) = Dossier & subdossier
DirList Dossier & subdossier & "\", True, tbl
Next subdossier
DirList = tbl
End Function