'Microsoft ActiveX Data Objects x.x Library
Dim Cn As ADODB.Connection
Dim Rs As ADODB.Recordset
Dim xConnect As String, Cible As String
Dim Fichier As String, Dossier As String, Feuille As String, fld as object
Dim i As Long, j as long
'nom du répertoire contenant les classeurs à regrouper
Dossier = "C:\temp"
'Nom de la feuille dans les classeurs fermés
'Ne pas oublier le symbole $ après le nom de la feuille
Feuille = "Feuil1$"
i = 2
Fichier = Dir(Dossier & "\*.xlsx")
'boucle sur les fichiers du repertoire
Do While Len(Fichier) > 0
xConnect = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & _
"ReadOnly=1;DBQ=" & Dossier & "\" & Fichier
'connection classeur
Set Cn = New ADODB.Connection
Cn.Open xConnect
'Requete
Cible = "SELECT [" & Feuille & "].*, '" & Replace(Replace(Fichier, ".xlsx", ""),"ventes_","") & "' as VILLE FROM [" & Feuille & "] where Catégorie = 6;"
Set Rs = New ADODB.Recordset
Rs.Open Cible, xConnect, adOpenStatic, adLockOptimistic, adCmdText
If i = 2 Then
j = 0
For Each fld In Rs.Fields
Cells(1, j + 1).Value = Rs.Fields(j).Name
j = j + 1
Next fld
End If
'Ecriture dans la feuille de calcul
If Not Rs.EOF Then Cells(i, 1).CopyFromRecordset Rs
i = Cells(i, 1).End(xlDown).Row + 1
Rs.Close
Cn.Close
Set Cn = Nothing
Set Rs = Nothing
Fichier = Dir()
Loop
MsgBox "Terminé"