VBA Excel - Listar archivos y características

Hola,
Si no es demasiado tarde o si el tema todavía le interesa, estoy dispuesta a ayudarle ya que estoy jubilada y he trabajado mucho con VBA.
Atentamente

Bonjour,

Soyez assuré que votre code peut effectivement être optimisé pour améliorer son efficacité lors de la recherche de fichiers. Voici quelques suggestions pour réduire le temps de traitement :

1. **Limiter la profondeur de recherche** : Vous pouvez limiter la profondeur de recherche dans les sous-dossiers si vous n'avez pas besoin de parcourir tous les niveaux.
2. **Utiliser des filtres dès le début** : Vous pouvez essayer de filtrer les fichiers dès que vous les trouvez au lieu de les stocker tous d'abord, puis de filtrer.
3. **Utiliser des tableaux dynamiques** : Au lieu d'ajouter des éléments un par un, vous pourriez ajouter directement dans un tableau dynamique, puis écrire toutes les valeurs dans la feuille d'un coup à la fin.
4. **Désactiver les mises à jour écran** : Bien que vous le fassiez déjà avec `Application.ScreenUpdating`, assurez-vous également de désactiver d'autres fonctionnalités comme `Application.Calculation` pendant l'exécution de votre script.
5. **Utiliser des objets Collection ou Dictionnaires** : Ces structures de données peuvent être plus efficaces pour stocker et gérer des listes de fichiers.

Voici une version modifiée de votre code intégrant certaines de ces suggestions :

```vba
Option Explicit

Sub ScanClasseursOptimise()
Dim Dossier As Object, Fichier As Object
Dim Chemin As String, CeFichier As String
Dim ExtFichier As String
Dim TabDossiers As Variant
Dim Resultats() As Variant
Dim L As Long, D As Long
Dim InitSB As Boolean

InitSB = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Chemin = "Z:\Mon travail\Bibliothèque\Produits intérieurs\EMH Trolleys\CH200"
If Chemin = "" Then Exit Sub
ThisWorkbook.Sheets("ListeDFT").Range("A2:C65536").Clear
CeFichier = ThisWorkbook.Name
ExtFichier = UCase(Trim(ThisWorkbook.Sheets("ListeDFT").Range("Extension").Text))

L = 0
TabDossiers = lstDossiers(Chemin, True)
For D = 1 To UBound(TabDossiers)
Chemin = TabDossiers(D)
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
For Each Fichier In Dossier.Files
If Fichier.Name <> CeFichier Then
If ExtFichier = "" Or UCase(Right(Fichier.Name, 4)) = ".DFT" Then
L = L + 1
ReDim Preserve Resultats(1 To 3, 1 To L)
Resultats(1, L) = Chemin
Resultats(2, L) = Fichier.Name
Resultats(3, L) = Fichier.DateCreated
Application.StatusBar = "ligne traitée : " & L
End If
End If
Next
Next D

' Écrit tous les résultats d'un coup
If L > 0 Then
With ThisWorkbook.Sheets("ListeDFT")
.Range("A2").Resize(L, 3).Value = Application.Transpose(Resultats)
For i = 1 To L
.Hyperlinks.Add Anchor:=.Cells(i + 1, 2), Address:=Resultats(1, i) & Resultats(2, i), _
TextToDisplay:=Resultats(2, i)
Next i
End With
End If

Columns("B:B").Select
Range("A1:C65536").Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox L & " fichiers trouvés !"
Application.StatusBar = False
Application.DisplayStatusBar = InitSB
End Sub

Private Function lstDossiers(Chemin As String, Optional Debut As Boolean) As Variant
Dim Dossier As Object, D As Object
Static TabTemp() As String
If Debut Then
ReDim TabTemp(1 To 1)
TabTemp(1) = Chemin
End If
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
For Each D In Dossier.subfolders
ReDim Preserve TabTemp(1 To UBound(TabTemp) + 1)
TabTemp(UBound(TabTemp)) = D.Path
lstDossiers D.Path
Next
lstDossiers = TabTemp()
Set Dossier = Nothing
End Function
```

En implémentant ces changements, vous devriez constater une amélioration significative du temps de traitement de votre script. N'hésitez pas à adapter ce code en fonction de vos besoins spécifiques.
Merci d'avance pour vos réponses.