Alternative a FSO

Bonjour je souhaiterais savoir si il existe une alternative a FSO car c'est actuellement la procedure que j'utilise mais le soucis est qu'il met environ 40Minute pour me sortir la liste de fichier que je veut j'ai bien essaye avec Dir mais je me noie :/

Private Sub Command1_Click()
Application.ScreenUpdating = False
Columns(1).ClearContents
 Cells(1, 1) = Timer
Dim fso As FileSystemObject, dossier As Folder, sousdossier As Folder, fichier As File

    Set fso = New FileSystemObject
    Set dossier = fso.GetFolder("Y:\")
    scan dossier
 Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) = Timer - Cells(1, 1)
 Application.ScreenUpdating = True

End Sub

Public Sub scan(ByVal dossier As Folder)

    For Each fichier In dossier.Files
        If InStr(fichier, "SLDDRW") <> 0 Then
        'Debug.Print fichier
        Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) = fichier
        End If
    Next

     For Each sousdossier In dossier.SubFolders
        'Debug.Print sousdossier
        scan sousdossier
    Next

End Sub
8listing-fso.xlsm (379.05 Ko)

Bonjour mallarddam,

j'ai fait le test sans la condition "SLDDRW" résultat: 1256 fichiers en 1 min 22 sec

Sub Fichiers()
'Application.ScreenUpdating = False
Dim myPath As String, myFile As String

myPath = ThisWorkbook.Path
myFile = Dir(myPath & "\*.xls*")

c = 1
Do While myFile <> ""
    If InStr(fichier, "SLDDRW") <> 0 Then Cells(c, 1) = myFile
    myFile = Dir()
    c = c + 1
Loop
End Sub

sabV Merci de ta réponse mais sauf erreur de ma part le code ne liste pas les sous dossier ?

EDIT j'ai essayé ce code la mais j'ai l'erreur suivante sur la ligne

myFolder = Dir()

Erreur d'exécution '5':

Argument ou appel de procédure incorect

Sub Liste(ByVal mypath As String)
Dim myFolder As String
myFolder = Dir(mypath & "*", vbDirectory)
Do While myFolder <> ""
    If (GetAttr(mypath & myFolder) And vbDirectory) = vbDirectory And Right(myFolder, 1) <> "." Then
        Liste (mypath & myFolder & "\")
    ElseIf Right(myFolder, 1) <> "." Then
        Debug.Print "Fichier: " & myFolder
    End If
    myFolder = Dir()
Loop
End Sub
Sub Test12()
Liste ("C:\test\")
End Sub

Bonjour,

Je ne suis pas sûr que le temps de réponse soit lié au modèle FSO car a priori balayer 20.000 fichiers ne devrait lui prendre que quelques minutes. L'unité Y ne serait-elle pas un lecteur réseau ? Il pourrait y avoir des lenteurs dans ce cas.

Bonjour thev en effet il s'agit d'un lecteur réseau (local) mais je pense que la lenteur se fait surtout au niveau du nombre de sous dossier je test actuelement ce code mais qui a tendance a planté des qu'il y a un caractere special dans le nom de fichier ou de dossier

Sub Retrieve_File_listingV2()
Application.screenupdateing = false
Cells(1,2) = Timer
Call Enlist_DirectoriesV2("Y:\")  
 Cells(Cells(Rows.Count, 2).End(xlUp).Row + 1, 2) = Timer - Cells(1,2)
Application.screenupdateing = true
End Sub  
Public Sub Enlist_DirectoriesV2(strPath As String)  
Dim strFldrList() As String  
Dim lngArrayMax, x As Long  
lngArrayMax = 0  
strFn = Dir(strPath & "*.*", 23)  
While strFn <> ""  
  If strFn <> "." And strFn <> ".." Then  
    If (GetAttr(strPath & strFn) And vbDirectory) = vbDirectory Then  
      lngArrayMax = lngArrayMax + 1  
      ReDim Preserve strFldrList(lngArrayMax)  
      strFldrList(lngArrayMax) = strPath & strFn & "\"  
    Elseif instr(strfn, "SLDDRW") <> 0 then
    Cells(Cells(Rows.Count, 2).End(xlUp).Row + 1, 2) = strPath & strFn  
    End If  
  End If  
  strFn = Dir()  
Wend  
If lngArrayMax <> 0 Then  
  For x = 1 To lngArrayMax  
    Call Enlist_DirectoriesV2(strFldrList(x))  
  Next  
End If  
End Sub

Pour analyser 87000 Fichier sur le réseau il met environ 4 Minute v'est déjà mieux

Rechercher des sujets similaires à "alternative fso"