Fusion n fichiers xls en 1 seul fichier

Const chemin As String = "D:\documents\bilbiane" 'à adapter au projet
Const Onglet As String * 6 = "bureau"
Const Plage As String * 9 = "B34:F1000"

Dim T_out, cptr As Integer

Function FichOuvert(F As String) As Boolean
'Auteur: Didier_mdf   (merci) :http://www.mdf-xlpages.com/
Dim Wk As Workbook
On Error Resume Next
Set Wk = Workbooks(F)
On Error GoTo 0
FichOuvert = Not Wk Is Nothing
End Function

Sub regrouper_pays()
Dim Fich As String

ReDim T_out(4, 0)
ChDir chemin
Fich = Dir("*.xls")
While Fich <> ""
   'teste si une source est ouverte et si oui, sauvegarde et ferme
    If FichOuvert(Fich) Then
            With Workbooks(Fich)
            If Not .Saved Then
                .Save
            End If
            .Close
        End With
    End If
    
'------extraction des données pays, nom,  voiture....
    extraire Fich
    Fich = Dir
    Wend
    
'-----Restitution
With Sheets(1)
    .Range("A2:E10000").Clear
    With .Range("A2").Resize(cptr, 5)
        .Value = Application.Transpose(T_out)
        .Borders.Weight = xlThin
    End With
End With

End Sub

Sub extraire(Fichier As String)
Dim Pays As String
Dim Source As Object, Requete As Object
Dim feuille As String * 7
Dim Texte_SQL As String

 'extraction cellule C17
    Pays = ExecuteExcel4Macro("'" & chemin & "\[" & Fichier & "]" & Onglet & "'!R17C3")

'connexion ADO au fichier-source
Set Source = CreateObject("ADODB.Connection")
    Source.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=" & chemin & "\" & Fichier & ";Extended Properties=""Excel 8.0;HDR=No;"";"
    
    feuille = Onglet & "$"
    Texte_SQL = "SELECT * FROM [" & feuille & Plage & "];"
    Set Requete = CreateObject("ADODB.Recordset")
    Set Requete = Source.Execute(Texte_SQL)
    
    'affectation des données au tableau de restitution
    With Requete
    .MoveFirst
    Do While Not .EOF
         ReDim Preserve T_out(4, cptr)
        T_out(0, cptr) = Pays
        T_out(1, cptr) = .Fields(0)
        T_out(2, cptr) = .Fields(1)
        T_out(3, cptr) = .Fields(2)
        T_out(4, cptr) = .Fields(3)
        cptr = cptr + 1
        .MoveNext
      Loop
    End With
    'libère la mémoire
    Requete.Close
    Set Requete = Nothing
    Source.Close
    Set Source = Nothing
    
    End Sub