Vba Pompages d'une ligne sur 100 ficher

Sub Recuperer60()

Const Repert = "D:\EXCEL\@EXCEL-DOWNLOADS\@TEST\Fact\Facturation"
Const LigneDepart = 2

Dim LesFichiers, i, rep As String
Dim Fichier As String, Ligne As Long

Application.ScreenUpdating = False
ThisWorkbook.Sheets("Lignes60").Activate

If Right(Repert, 1) <> "\" Then rep = Repert & "\" Else rep = Repert

Ligne = LigneDepart
Fichier = Dir(rep & "*.xlsm")

Do While Fichier <> ""
  If Not IsArray(LesFichiers) Then
    ReDim LesFichiers(1 To 1)
  Else
    ReDim Preserve LesFichiers(1 To UBound(LesFichiers) + 1)
  End If
  LesFichiers(UBound(LesFichiers)) = rep & Fichier
  Fichier = Dir
Loop

Ligne = LigneDepart
With ThisWorkbook.Sheets("Lignes60")
  .Range("A" & Ligne & ":A" & .Rows.Count).Clear
  If Not IsArray(LesFichiers) Then Exit Sub
  .Range("A" & Ligne).Resize(UBound(LesFichiers)).Value = Application.Transpose(LesFichiers)
  .Range("A" & Ligne).Resize(UBound(LesFichiers)).Sort key1:=.Range("A" & Ligne), Header:=xlNo
   LesFichiers = .Range("A" & LigneDepart).Resize(UBound(LesFichiers)).Value
  .Range("A" & Ligne & ":A" & .Rows.Count).Clear
End With

For i = 1 To UBound(LesFichiers)
  Workbooks.Open LesFichiers(i, 1)
  ActiveWorkbook.ActiveSheet.Rows(60).Copy
  ThisWorkbook.Sheets("Lignes60").Rows(Ligne).PasteSpecial Paste:=xlPasteValues
  Application.DisplayAlerts = False
  ActiveWorkbook.Close Savechanges:=False
  Application.DisplayAlerts = True
  Ligne = Ligne + 1
Next i

Application.CutCopyMode = False
Application.Goto Range("A" & IIf(LigneDepart = 1, 1, LigneDepart - 1)), True
Application.ScreenUpdating = True
End Sub

Option Explicit
Option Base 1
Sub Recuperer60()

Const Repert = "C:\Fact\Facturation"
Const LigneDepart = 2
Dim i&, k&, Ligne&, rep$, LesFichiers(), Fichier$

Application.ScreenUpdating = False
ThisWorkbook.Sheets("Lignes60").Activate

If Right(Repert, 1) <> "\" Then rep = Repert & "\" Else rep = Repert
Fichier = Dir(rep & "*.xlsm")
Do While Fichier <> ""
  k = k + 1
  ReDim Preserve LesFichiers(1 To k)
  LesFichiers(k) = rep & Fichier
  Fichier = Dir
Loop

With ThisWorkbook.Sheets("Lignes60")
  .Range("A" & LigneDepart & ":A" & .Rows.Count).Clear
  If k = 0 Then Exit Sub
  .Range("A" & LigneDepart).Resize(k).Value = Application.Transpose(LesFichiers)
  If k > 1 Then .Range("A" & LigneDepart).Resize(k).Sort _
            key1:=.Range("A" & LigneDepart), Header:=xlNo
  LesFichiers = .Range("A" & LigneDepart).Resize(k + 1).Value
  .Range("A" & LigneDepart & ":A" & .Rows.Count).Clear

  Ligne = LigneDepart
  For i = 1 To k
    Workbooks.Open LesFichiers(i, 1)
    ActiveWorkbook.ActiveSheet.Rows(60).Copy
    .Rows(Ligne).PasteSpecial Paste:=xlPasteValues
    Application.DisplayAlerts = False
    ActiveWorkbook.Close Savechanges:=False
    Application.DisplayAlerts = True
    Ligne = Ligne + 1
  Next i
End With

Application.CutCopyMode = False
Application.Goto Range("A" & IIf(LigneDepart = 1, 1, LigneDepart - 1)), True
Application.ScreenUpdating = True
End Sub