Sub testXy()
Cells.Clear
Dim liste As Variant
liste = DirList("G:\vba excel\")
Cells(1, 1).Resize(UBound(liste(0)), 1).Value = Application.Transpose(liste(0))
Cells(1, 2).Resize(UBound(liste(1)), 1).Value = Application.Transpose(liste(1))
End Sub
Function DirList(Dossier As String, Optional recall As Boolean = False, Optional tbl As Variant, Optional tblval 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): ReDim tblval(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 generant 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
If Right(ItemVu, 5) Like ".xls*" Then
A = UBound(tbl) + 1
ReDim Preserve tbl(1 To A): tbl(A) = Dossier & ItemVu
argument = "'" & Dossier & "[" & ItemVu & "]Feuil1'!" & Range("D2").Address(, , xlR1C1)
ReDim Preserve tblval(1 To A): tblval(A) = ExecuteExcel4Macro(argument)
End If
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, tblval
Next subdossier
DirList = Array(tbl, tblval)
End Function