Copier la meme cellule de plusieurs classeur dans un autre

Sub boucle()
Dim fso As Object, dossier As Object, fichier As Object
Dim W1 As Workbook, wb As Workbook
Dim Derligne As Integer
Set W1 = Workbooks(ThisWorkbook.Name) 'classeur reception
Derligne = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1 '1ère ligne vide classeur reception
Set fso = CreateObject("Scripting.FileSystemObject")
Set dossier = fso.GetFolder(ThisWorkbook.Path) 'chemin dossier classeur
On Error Resume Next
Application.ScreenUpdating = False
For Each fichier In dossier.Files
    If fichier = ThisWorkbook.Path & "\" & ThisWorkbook.Name Then 'chemin classeur reception
    Else
    Set wb = Workbooks.Open(fichier)
         W1.ActiveSheet.Range("A" & Derligne).Value = wb.ActiveSheet.Range("F60").Value
        wb.Close
        Derligne = Derligne + 1
        End If
Next fichier
Application.ScreenUpdating = True
End Sub

Sub transferer()
Dim lig As Long
Dim recap As String, chemin As String, onglet As String
Dim fich As String

recap = ThisWorkbook.Name
onglet = "feuil1" ' A ADAPTER
chemin = "C:/......." 'CHEMIN COMPLET DU REPERTOIRE SOURCE ?
Application.ScreenUpdating = False
Range("A2:A1000").ClearContents
lig = 2

ChDir chemin
fich = Dir("*.xls*")
While fich <> ""
    If fich <> recap Then
              Cells(lig, 1) = ExecuteExcel4Macro("'" & chemin & "\[" & fich & "]" & onglet & "'!R60C6")  'R60C6<==> F60
    lig = lig + 1
    End If
    fich = Dir
Wend

MsgBox "récapitulatif  terminé avec succès"
End Sub