Bonjour,
Voici un exemple pour récupérer les adresses courriel
Avant d 'exécuter la macro, n'oublie pas de modifier les lignes qui ont un commentaire " à adapter "
et activer la référence: Microsoft ActiveX Data Objects xx Library -->au menu vba, Outils, Référence
Sub Read_File_one_Range()
Dim Repertoire As String, Fichier As String, Feuille As String, AddrLire As String
Dim Ligne As Long, oFile As Object
'Sheets.Add After:=Sheets(Sheets.Count) 'à adapter
Repertoire = "C:\Users\isabelle\Documents\Test9" 'à adapter
Set fso = CreateObject("Scripting.FileSystemObject")
Set sfofolder = fso.GetFolder(Repertoire)
NomFeuille = "Donnees$" 'à adapter
AddrLire = "D9:D9"
Ligne = 2
For Each oFile In sfofolder.Files
If Right(oFile, 5) = ".xlsx" Then 'à adapter
Set Cnn = New ADODB.Connection
'--- Connexion ---
With Cnn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
& oFile & ";Extended Properties=""Excel 12.0;HDR=NO;"""
.Open
End With
'--- récupérer les données --
Set rs = Cnn.Execute("SELECT * FROM [" & NomFeuille & AddrLire & "]")
Cells(Ligne, "A").CopyFromRecordset rs
rs.Close
Ligne = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
End If
Next oFile
Cnn.Close
Set rs = Nothing
Set Cnn = Nothing
End Sub