Plus rapide

Option Compare Text

Private Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
  dwFileAttributes As Long
  ftCreationTime As FILETIME
  ftLastAccessTime As FILETIME
  ftLastWriteTime As FILETIME
  nFileSizeHigh As Long
  nFileSizeLow As Long
  dwReserved0 As Long
  dwReserved1 As Long
  cFileName As String * 260
  cAlternate As String * 14
End Type

Private Declare Function FindFirstFileA Lib "Kernel32" _
  (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindNextFileA Lib "Kernel32" _
  (ByVal hFindfile As Long, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindClose Lib "Kernel32" _
  (ByVal hFindfile As Long) As Long

Const Masque = "*.*" 'à définir

Dim Arr() As String
Dim NbFichiers As Long
Dim FileFindData As WIN32_FIND_DATA
Dim Fichier As String

Sub Test()
  ReDim Arr(1 To 1)
  NbFichiers = 0
  Recurse "c:\Users\Ton profil\Documents\"
  Application.ScreenUpdating = False
  With Range("A1").Resize(NbFichiers)
    .Value = Application.Transpose(Arr)
    .Sort [A1]
    .EntireColumn.AutoFit
  End With
End Sub

Private Sub Recurse(ByVal Chemin As String)
  Dim hFindfile As Long
  hFindfile = FindFirstFileA(Chemin & "*.*", FileFindData)
  If Chemin <> "D:\" Then
    FindNextFileA hFindfile, FileFindData
    If FindNextFileA(hFindfile, FileFindData) = 0 Then
      FindClose hFindfile
      Exit Sub
    End If
  End If
  Do
    Fichier = Chemin & Left$(FileFindData.cFileName, _
      InStr(1, FileFindData.cFileName, vbNullChar) - 1)
    If GetAttr(Fichier) And vbDirectory Then
      Recurse Fichier & "\"
    ElseIf Fichier Like Masque Then
      NbFichiers = NbFichiers + 1
      ReDim Preserve Arr(1 To NbFichiers)
      Arr(NbFichiers) = Fichier
    End If
  Loop While FindNextFileA(hFindfile, FileFindData)
  FindClose hFindfile
End Sub

Dim fso, rep, f
Set fso = CreateObject("Scripting.FileSystemObject")
Set rep = fso.GetFolder(ThisWorkbook.Path & "\Fiche MP\")
Set f = rep.Files
MsgBox f.Count

Option Explicit
Private Sub Workbook_Open()
Application.ScreenUpdating = 0
 
    Dim fCount As Long
    Dim sPath As String
    Dim Tmp As String
    Dim FolderFiles() As Variant
    
  sPath = ThisWorkbook.Path & "\Fiche MP\"
  fCount = 0
  Tmp = Dir(sPath & "*.*")
  While Tmp <> Empty
    fCount = fCount + 1
    ReDim Preserve FolderFiles(1 To fCount)
    FolderFiles(fCount) = Tmp
    Tmp = Dir
  Wend
  
  If Cells(1, 28).Value = fCount Then NonFiltre: Exit Sub
  
Call ListeTablo

End Sub

Sub test()
Dim Dossier As Object
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path & "\Fiche MP\")
MsgBox Dossier.Files.Count
End Sub

Option Explicit
Private Sub Workbook_Open()
Application.ScreenUpdating = 0
 
  Dim Dossier As Object
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path & "\Fiche MP\")

  If Cells(1, 28).Value = Dossier.Files.Count Then NonFiltre: Exit Sub
  
Call ListeTablo

End Sub