1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52
| Option Explicit
Sub compiler()
'Nécessite d'activer la Référence (Dans Outils/référence)
'Microsoft ActiveX Data Objects x.x Library
Dim Cn As Object 'ADODB.Connection
Dim Rst As Object ' ADODB.Recordset
Dim Cible As String
Dim Fichier As String, Dossier As String, Feuille As String
Dim i As Long
Dim c As Long
'Nom du répertoire contenant les classeurs à regrouper
Dossier = "C:\Users\XXX\Documents\Test Excel"
'Nom de la feuille dans les classeurs fermés
'Ne pas oublier le symbole $ après le nom de la feuille
'La feuille d'import doit avoir le même nom que les feuilles importées
Feuille = "TestReport$"
i = 2
'Permet de ne pas cumuler plusieurs fois les mêmes nomenclatures
'Effacement des cellules d'arrivée afin d'avoir une feuille vide et ainsi éviter les doublons
Range("A2:L65400").Delete
Fichier = Dir(Dossier & "\*.xls*")
'Boucle sur les fichiers du repertoire
'Connection Dossier
Set Cn = CreateObject("ADODB.Connection")
Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Dossier & ";Extended Properties = text"
Do While Len(Fichier) > 0
'Requete
Cible = "SELECT * FROM [" & Feuille & "]in '" & Dossier & "\" & Fichier & "' 'excel 8.0;HDR=YES""' ;"
Set Rst = CreateObject("ADODB.Recordset")
Rst.Open Cible, Cn
For c = 0 To Rst.Fields.Count - 1
Range("A1").Offset(0, c) = Rst(c).Name
Next
'Ecriture dans la feuille de calcul
Cells(i, 1).CopyFromRecordset Rst
i = Cells(Cells.Rows.Count, 1).End(xlUp).Row + 1
Rst.Close
Set Rst = Nothing
Fichier = Dir()
Loop
Cn.Close
Set Cn = Nothing
MsgBox "Réception des fichiers Excel terminée."
End Sub |
Partager