Liste automatique

Option Explicit
'RECUPERATION REPERTOIRES ET NOMS DE FICHIERS DANS UN CLASSEUR
' (Exécuter la macro AfficheFichiers())
Sub AfficheFichiers()
Dim LeChemin As String
Dim Lextension As String
Dim LeTitre As String
Dim Arret As Boolean

  LeTitre = "Répertoires et sous-répertoires"
  Arret = False
  Application.ScreenUpdating = True
   Range("A1").Activate
  Do
    LeChemin = ChoisirDossier
    If Len(LeChemin) = 0 Then
      Arret = True
    Else
      If Mid(LeChemin, Len(LeChemin), 1) <> "" Then
        LeChemin = LeChemin + ""
      End If
      If Len(Dir(LeChemin, vbDirectory)) <> 0 Then
        Lextension = "*.*"
        Call Remplir(LeChemin, Lextension)
        Arret = True
      Else
       MsgBox "Répertoire introuvable...Recommencer ?"
      End If
    End If
  Loop Until Arret
  End Sub
Private Sub Remplir(RepertParent, ExtFichier)
' Remplit la feuille courante avec le contenu du répertoire RepertParent
' Les noms de répertoires sont placés dans la colonne active à partir de
' la cellule active
' Les noms de fichiers correspondants à ExtFichier sont affichés dans la
' colonne de droite
' 14/02/2000 18:30, Gérard B, mpfe

Dim Compteur As Integer
Dim NbreRepert As Integer
Dim LeFichier As String
Dim LeDossier As String
Dim ExtLocale As String
Dim ParentLocal As String
Dim LeDossierLocal() As String
Dim ext As String
    ExtLocale = ExtFichier
    LeFichier = Dir(RepertParent & ExtFichier)
    If Len(LeFichier) = 0 Then
        ActiveCell.Value = RepertParent
        ActiveCell.Offset(1, 1).Select
    End If
    Do While Len(LeFichier) <> 0
       ' ActiveCell.Value = (RepertParent & LeFichier)
       ' ActiveCell.Offset(1, 0).Select
       ext = Right(LeFichier, 4) ' renvoie ".ext"
       LeFichier = Replace(LeFichier, ext, "") 'supprime l'extension
       ActiveCell.Value = LeFichier
        ActiveCell.Offset(1, 0).Select
        LeFichier = Dir
    Loop
    'Compter le nombre de sous-répertoires
    NbreRepert = 0
    LeDossier = Dir(RepertParent, vbDirectory)
    Do While LeDossier <> ""
        If LeDossier <> "." And LeDossier <> ".." Then
            If (GetAttr(RepertParent & LeDossier) _
                    And vbDirectory) = vbDirectory Then
                NbreRepert = NbreRepert + 1
            End If
        End If
        LeDossier = Dir
    Loop
    ReDim LeDossierLocal(NbreRepert + 1)
    Compteur = 1
    LeDossierLocal(Compteur) = Dir(RepertParent, vbDirectory)
    Do While LeDossierLocal(Compteur) <> ""
        If LeDossierLocal(Compteur) <> "." _
                    And LeDossierLocal(Compteur) <> ".." Then
            If (GetAttr(RepertParent & LeDossierLocal(Compteur)) _
                        And vbDirectory) = vbDirectory Then
                Compteur = Compteur + 1
            End If
        End If
        LeDossierLocal(Compteur) = Dir
    Loop
    For Compteur = 1 To UBound(LeDossierLocal()) - 1
        ParentLocal = RepertParent & LeDossierLocal(Compteur) & ""
        Call Remplir(ParentLocal, ExtLocale)
    Next
End Sub

Function ChoisirDossier()
    Dim objShell, objFolder, chemin As String, SecuriteSlash
                                            
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(&H0&, "Choisisser un répertoire", &H1&)
    On Error Resume Next
    chemin = objFolder.Items.Item.Path

    SecuriteSlash = InStr(objFolder.Title, ":")

    If SecuriteSlash > 0 Then
        chemin = Mid(objFolder.Title, SecuriteSlash - 1, 2) & ""
    End If
    ChoisirDossier = chemin
End Function

AfficheFichiers

  ' create a new workbook for the file list
 ' Workbooks.Add
  ActiveSheet.Cells.Clear