Macro boucle de moin en moin rapide

Bonjour,

J'utilise une macro pour extraire les titre des fichier dans un dossier,
La maccro dure en moyen 9s pour extraire les 16 000 fichier , mais plus j'utilise plus elle dure longtemp.10 min au lieu de 9s au bou de la 4 utilisation et je ne sais pas pourquoi.

Je n'ai pas trouvé de macro me permétant de sélectionné les fichier les plus récent rapidement.

Voici la macro


'Recupere les noms de fichiers d'un répertoire dans un tableau

Sub RecupNomFichier(ByVal Chemin As String, ByRef Tableau As Variant)
Dim Fichier As String
Dim Compteur As Integer
Dim LigneCompteur As Integer
Dim i As Integer 'index ligne feuille excel


'Chemin = Application.InputBox(Prompt:="Quel répertoire voulez-vous imprimer?")
Chemin = Range("A2")
Chemin = Chemin + "\*.*"
'Range("B1") = Chemin
Compteur = 1
Fichier = Dir(Chemin)
Do While (Len(Fichier) > 0)
ReDim Preserve Tableau(Compteur)
Tableau(Compteur - 1) = Fichier
LigneCompteur = Compteur + 1
ActiveSheet.Range("B" & LigneCompteur).Value = Tableau(Compteur - 1)
Compteur = Compteur + 1
Fichier = Dir()
Loop
End Sub

Sub RecupFichierTableau()
On Error Resume Next
Application.ScreenUpdating = False
Dim Tableau() As String
Call RecupNomFichier(Chemin, Tableau)
FiltreAlpha
Columns("B:B").Select
Selection.Replace What:=".pdf", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="#", Replacement:="/", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("C1").Select
End Sub

Sub FiltreAlpha()

Columns("B:B").Select
Selection.Sort Key1:=Range("C2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
With Selection
.HorizontalAlignment = xlGeneral
.Orientation = 0
End With
With Selection
.HorizontalAlignment = xlRight
.Orientation = 0
End With
Range("B1").Select
End Sub