Copier la valeur de cellules de fichiers fermés sur un autre fichier

Sub CopierFichiers()
Dim t, chemin$, W As Worksheet, feuil$, lig&, fichier$
Dim F As Worksheet, P As Range, PBV As Range, a(), rc&, cc As Byte, b()
Dim col As Byte, c As Range, n&, i&, j As Byte
t = Timer 'mesure facultative
chemin = ThisWorkbook.Path & "\"
Set W = Feuil1 'CodeName de la feuille Bilan
feuil = "Tableau-Enquete" 'nom à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier est déjà ouvert
W.Rows("2:" & W.Rows.Count).Delete 'RAZ
lig = 2
fichier = Dir(chemin & "*.xls*") '1er fichier du dossier
While fichier <> ""
  If fichier <> ThisWorkbook.Name Then
    Set F = Workbooks.Open(chemin & fichier).Sheets(feuil) 'ouverture du fichier
    Set P = F.[F26,A26,A30,F30,C40:F40,F45,F46,F51,D94:F94]
    Set PBV = F.[B54:F93]
    ReDim a(1 To P.Count) 'tableau pour accélérer
    rc = PBV.Rows.Count: cc = PBV.Columns.Count
    ReDim b(1 To rc, 1 To cc) 'tableau pour accélérer
    col = 0
    For Each c In P
      col = col + 1
      a(col) = c
    Next
    W.Cells(lig, 1).Resize(, col) = a
    n = 0
    For i = 1 To rc
      If Application.CountA(PBV.Rows(i)) > 1 Then
        n = n + 1
        For j = 1 To cc
          b(n, j) = PBV(i, j)
        Next
      End If
    Next
    If n Then
      W.Cells(lig, col + 1).Resize(n, cc) = b
      W.Cells(lig, 1).Resize(, col).Copy W.Cells(lig, 1).Resize(n, col) 'est-ce nécessaire ???
    End If
    F.Parent.Close False 'fermeture du fichier
    lig = lig + n
  End If
  fichier = Dir 'fichier suivant du dossier
Wend
W.Activate
MsgBox "Durée " & Format(Timer - t, "0.00 \s") 'mesure facultative
End Sub

If Application.CountA(PBV.Rows(i)) > 1 Then

Sub CopierFichiers()
Dim t, chemin$, W As Worksheet, feuil$, lig&, fichier$
Dim P As Range, PBV As Range, a(), rc&, cc As Byte, b()
Dim col As Byte, c As Range, formule$, n&, i&, ad$, j As Byte
t = Timer 'mesure facultative
'---préparation---
chemin = ThisWorkbook.Path & "\"
Set W = Feuil1 'CodeName de la feuille Bilan
feuil = "Tableau-Enquete" 'nom à adapter
lig = 2
fichier = Dir(chemin & "*.xls*") '1er fichier du dossier
Application.ScreenUpdating = False
W.Rows("2:" & W.Rows.Count).Delete 'RAZ
Set P = [F26,A26,A30,F30,C40:F40,F45,F46,F51,D94:F94]
Set PBV = [B54:F93]
ReDim a(1 To P.Count) 'tableau pour accélérer
rc = PBV.Rows.Count: cc = PBV.Columns.Count
ReDim b(1 To rc, 1 To cc) 'tableau pour accélérer
'---traitement des fichiers sources---
While fichier <> ""
  If fichier <> ThisWorkbook.Name Then
    fichier = Replace(fichier, "'", "''")
    col = 0
    For Each c In P
      col = col + 1
      formule = "='" & chemin & "[" & fichier & "]" & feuil & "'!" & c.Address
      a(col) = formule
    Next
    W.Cells(lig, 1).Resize(, col) = a
    n = 0
    For i = 1 To rc
      ad = PBV.Rows(i).Address(ReferenceStyle:=xlR1C1)
      formule = "COUNT('" & chemin & "[" & fichier & "]" & feuil & "'!" & ad & ")"
      If ExecuteExcel4Macro(formule) Then 's'il y a au moins 1 nombre
        n = n + 1
        For j = 1 To cc
          formule = "='" & chemin & "[" & fichier & "]" & feuil & "'!" & PBV(i, j).Address
          b(n, j) = formule
        Next
      End If
    Next
    If n Then
      W.Cells(lig, col + 1).Resize(n, cc) = b
      W.Cells(lig, 1).Resize(n, col) = W.Cells(lig, 1).Resize(, col).Value 'nécessaire ???
    End If
    lig = lig + n
  End If
  fichier = Dir 'fichier suivant du dossier
Wend
W.UsedRange = W.UsedRange.Value 'supprime les formules
W.Activate
MsgBox "Durée " & Format(Timer - t, "0.00 \s") 'mesure facultative
End Sub