Sub CommandButton1_Click()
'sources XLD,WROX
Dim connect As String
Dim Sql As String, onglet As String
Dim data As ADODB.Recordset
Dim Fichier As String, Direction As String, texte_SQL As String
Dim X As Integer, NbFichiers As Integer, N As Integer, p As Integer, w As Integer
Dim Tableau() As String
onglet = InputBox('Saisissez le nom d'un onglet :')
If onglet = '' Then Exit Sub
Direction = Dir(ThisWorkbook.Path & '\\*.xls')
Do While Len(Direction) > 0 'liste tous les classeurs du repertoire
NbFichiers = NbFichiers + 1
ReDim Preserve Tableau(1 To NbFichiers)
Tableau(NbFichiers) = Direction
Direction = Dir()
Loop
If NbFichiers > 0 Then
For X = 1 To NbFichiers 'boucles sur les classeurs
' pour ne pas prendre en compte le classeur contenant la macro (synthese)
If Tableau(X) <> ThisWorkbook.Name Then
Fichier = ActiveWorkbook.Path & '\\' & Tableau(X)
N = 0
connect = 'Provider = Microsoft.Jet.OLEDB.4.0;' & _
'data source=' & Fichier & ';' & _
'extended properties=''Excel 8.0;HDR=no;'';'
'ici la zone a copier dans la feuille dim
Sql = 'SELECT * FROM [' & onglet & '$t9:t55]'
Set data = New ADODB.Recordset
data.Open Sql, connect, adOpenForwardOnly, _
adLockReadOnly, adCmdText
Do While Not data.EOF
' pour etre synchro avec les colonnes
p = X - 1
Cells(3, 2 + p) = Tableau(X)
Cells(N + 4, 2 + p).CopyFromRecordset data
N = N + 1
Loop
End If
Next X
End If
Application.ScreenUpdating = True
'delete de l'objet recordset
data.Close
Set data = Nothing
specification
'supprimer lignes vides à partir de ligne3
'For w = Range('b65536').End(xlUp).Row To 3 Step -1
' If Cells(w, 1) = '' Then
' Rows(w).Delete
' End If
'Next w
End Sub