Classeur qui se traine !

Sub ListeTablo()



  Dim DLig As Long, FolderFiles() As Variant
  Dim Tmp As String, fCount As Long
  Dim Ind
  Dim sPath As String
  ' Désinhiber certaines fonctions d'Excel
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
  
  With Sheets("Choix")
    .Activate
    DLig = .Range("R" & Rows.Count).End(xlUp).Row
    If DLig >= 2 Then
      .Range("A2:T" & DLig).ClearContents
    End If
    .Rows("1:1").AutoFilter Field:=17, Criteria1:="="
  End With
  On Error Resume Next
  ActiveSheet.ShowAllData
  On Error GoTo 0
  
  MiseEnPlaceColonnes
  
  ' Initialisation
  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
  
  ' Transposer le tableau dans la colonne R
  Dim L&, C&, TSpl
  
  ReDim Trésu(1 To fCount, 1 To 19)
  For L = 1 To fCount
   TSpl = Split(Replace(FolderFiles(L), ".xls", "________"), "_")
    For C = 1 To 17: Trésu(L, C) = TSpl(C): Next C
    Trésu(L, 18) = FolderFiles(L)
    Trésu(L, 19) = "Fiche " & L
    Next L
  Cells(2, 1).Resize(fCount, 19).Value = Trésu
  
  Cells(1, 28).Value = L - 1 'Le Nombre de Fichier en AB1
  
  Remiseazero
  
  ' Inhiber certaines fonctions d'Excel
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic
  
  Cells.Sort Key1:=Range("R1"), Order1:=xlDescending, Header:=xlYes, _
                 OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                 DataOption1:=xlSortNormal

  Range("T1").Select
  MsgBox "La Base est à jour !" & Chr$(13) & Chr$(13) & "Avec " & Cells(1, 28).Value & " fiches de Maintenance"
End Sub