Private Sub Workbook_Activate()
Dim chemin$, fichier$, feuille$, source, lig, Cn As Object, Cd As Object, Rst As Object, col%, resu(), i%
chemin = ThisWorkbook.Path & Application.PathSeparator
fichier = Dir(chemin) '1er fichier du dossier
feuille = "Feuil1" 'feuille source à copier
source = Array("B4", "B5", "B6", "G3", "G4", "G9", "H9", "J19", "J20", "J21", "J22", "J23", "J24") 'adresses des cellules
lig = Array(3, 4, 5, 6, 7, 8, 9, 12, 13, 14, 15, 16, 17) 'lignes de destination
Set Cn = CreateObject("ADODB.Connection")
Set Cd = CreateObject("ADODB.Command")
Set Rst = CreateObject("ADODB.Recordset")
While fichier <> ""
If Right(fichier, 5) = ".xlsx" Then
col = col + 1
Cn.Open = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & chemin & fichier & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1;"""
Cd.ActiveConnection = Cn
ReDim Preserve resu(1 To 17, 1 To col) 'tableau des résultats
resu(2, col) = Left(fichier, Len(fichier) - 5)
For i = 0 To UBound(source)
Cd.CommandText = "SELECT * FROM [" & feuille & "$" & source(i) & ":" & source(i) & "]"
Rst.Open Cd, , 1, 3
resu(lig(i), col) = Rst(0)
Rst.Close
Next i
Cn.Close
End If
fichier = Dir 'fichier suivant
Wend
'---restitution---
With Sheets("Feuil1")
If .FilterMode Then .ShowAllData 'si la feuille est filtrée
With .[B1] '1ère cellule de destination
If col Then .Resize(UBound(resu), col) = resu
.EntireColumn.Offset(, col).Resize(, .Parent.Columns.Count - col - .Column + 1).Delete 'RAZ à droite
End With
.Columns.AutoFit 'ajustement largeurs
With .UsedRange: End With 'actualise la barre de défilement horizontale
End With
End Sub