Boostez vos compétences Excel avec notre communauté !
Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !
www.excel-downloads.com
Option Explicit
Private TRés(), LCou As Long, FSO As New FileSystemObject
Sub ListeFic()
ReDim TRés(1 To 10000, 1 To 2)
LCou = 0
Lister FSO.GetFolder(ActiveSheet.Cells(1, "A").Value)
ActiveSheet.Rows(3).Resize(10000).Delete
ActiveSheet.[A3].Resize(LCou, 2).Value = TRés
Erase TRés
End Sub
Private Sub Lister(ByVal Fdr As Scripting.Folder)
Dim ChemDoss As String, FdrS As Scripting.Folder, Fle As Scripting.File
ChemDoss = Fdr.Path
On Error Resume Next
For Each Fle In Fdr.Files
If Fle Is Nothing Then Exit For
LCou = LCou + 1
TRés(LCou, 1) = ChemDoss
TRés(LCou, 2) = Fle.Name
Next Fle
For Each FdrS In Fdr.SubFolders
If FdrS Is Nothing Then Exit Sub
Lister FdrS: Next FdrS
End Sub
'***************************************************
'lister dossier et sub dossiers et fichier
'fonction récursive avec DIR
'patricktoulon su Developpez.com
'version 1.2A
'date version:15/04/2017
'***************************************************
Sub testXy()
Cells.Clear
Dim liste As Variant
liste = DirList("H:\")
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 recall = False Then ReDim tbl(0) ' si recall on redim un tableau de zero item (pour la creation du tableau)
On Error Resume Next 'gestion des fichiers dossiers system et interdit ou générant une erreur(PerLog,recycle,etc..)
ItemVu = Dir(Dossier, vbDirectory)
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
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
