Sub Transferer()
Dim dossier As Object, Fichier As Object, Chemin As String, Lg As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = True
DerLg = Range("D65536").End(xlUp).Row + 1
Range("D3:D" & DerLg).Delete
Chemin = ThisWorkbook.Path
FName = Dir(Chemin & "\" & "*.xls")
Set dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
Lg = 3
For Each Fichier In dossier.Files
NomFichier = Fichier.Name
If Not Fichier.Name = "Analytique OGP HEURE SUP.xls" Then
Workbooks.Open Filename:=Chemin & "/" & NomFichier
On Error Resume Next
With Workbooks(NomFichier)
.Sheets("Feuil1").Range("N1").Copy ThisWorkbook.Sheets("HEURE SUP").Range("D" & Lg)
.Close
Lg = Lg + 1
End With
End If
Next
End Sub