'   Références  Microsoft ADO Ext. 2.8 for DLL and Security
'               Microsoft ActiveX Data Objects 2.x Library
 
Option Explicit
 
Sub SelFichier()
Dim Fichier As Variant
 
    ChDir ThisWorkbook.Path
 
    Fichier = Application.GetOpenFilename("Fichier xls (*.xls), *.xls" )
    If Fichier <> False Then
        Application.ScreenUpdating = False
        ListeNomFeuilles (Fichier)
        Application.ScreenUpdating = True
    End If
End Sub
 
Private Sub ListeNomFeuilles(sNom As String)
Dim Conn As Object
Dim Cat As Object
Dim FeuilleXL As Object
Dim iRow As Long
 
    ShDatas.Cells.Clear
    Set Conn = CreateObject("ADODB.Connection" )
    Set Cat = CreateObject("ADOX.Catalog" )
 
    Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & sNom & ";Extended Properties=Excel 8.0;"
 
    Set Cat.ActiveConnection = Conn
 
    iRow = 1
    For Each FeuilleXL In Cat.Tables
        Select Case Right$(FeuilleXL.Name, 1)
            Case "$"
                ShDatas.Cells(iRow, 1) = Left$(FeuilleXL.Name, Len(FeuilleXL.Name) - 1)
                iRow = iRow + 1
            Case "'"
                ' Nom de feuille comportant des espaces
                ShDatas.Cells(iRow, 1) = Mid$(FeuilleXL.Name, 2, Len(FeuilleXL.Name) - 3)
                iRow = iRow + 1
        End Select
    Next FeuilleXL
 
    Conn.Close
    Set Conn = Nothing
    Set Cat = Nothing
End Sub

Option Explicit
 
Private Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
 
Dim Debut As Currency, Fin As Currency, Freq As Currency
Dim TabFichiers() As String, NbFichiers As Long
Dim sNom As String
 
Sub SelDossier()
Dim sChemin As String
    sChemin = ThisWorkbook.Path
 
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin & "\"
        .Title = "Sélectionner le Dossier Racine"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            DoEvents
            NbFichiers = 0
            ShDatas.Cells.Clear
            LectureFichiersCSV .SelectedItems(1)
        End If
    End With
End Sub
 
Private Sub LectureFichiersCSV(sDossier As String)
Dim sChemin As String, sFichier As String
Dim iNumFree As Integer, i As Long
Dim  j As Long
Dim Wkb As Workbook
 
    Application.StatusBar = ""
    QueryPerformanceCounter Debut
    Close
 
    sChemin = sDossier
    iNumFree = FreeFile
 
    Application.ScreenUpdating = False
    sNom = "Lecture CSV.csv"
 
    '   Recherche   Récursive  ListeFichiersDossier sDossier, True
    '               Non Récursive  ListeFichiersDossier sDossier, False
    ListeFichiersDossier sDossier, True
    If NbFichiers = 0 Then Exit Sub
 
    j = 1
    For i = 1 To UBound(TabFichiers)
        sFichier = TabFichiers(i)
        Set Wkb = Workbooks.Open(Filename:=sFichier, Local:=True)
        With ShDatas
            .Range("A" & j) = Wkb.Worksheets(1).Range("A1" )
            .Range("B" & j) = Wkb.Worksheets(1).Range("B3" )
        End With
        j = j + 1
        Wkb.Close
        Application.StatusBar = i & " / " & NbFichiers
    Next i
 
    Set Wkb = Nothing
    Erase TabFichiers
 
    Application.ScreenUpdating = True
 
    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
    Application.StatusBar = Application.StatusBar & " : " & Format((Fin - Debut) / Freq, "0.00 s" )
 
End Sub
 
Private Sub ListeFichiersDossier(sChemin As String, bInclureSousDossiers As Boolean)
Dim FSO As Object, Dossier As Object, sFichier As String
Dim sPath As String, Pos As Long
 
    Set FSO = CreateObject("Scripting.FileSystemObject" )
    Set Dossier = FSO.GetFolder(sChemin)
 
    sFichier = Dir$(sChemin & "\*.csv" )
    Do While Len(sFichier) > 0
        Pos = InStrRev(sFichier, "\" )
        If Right$(sFichier, Len(sFichier) - Pos) <> sNom Then
            sPath = sChemin & "\" & sFichier
            NbFichiers = NbFichiers + 1
            ReDim Preserve TabFichiers(1 To NbFichiers)
            TabFichiers(NbFichiers) = sPath
        End If
        sFichier = Dir$()
    Loop
 
    If bInclureSousDossiers Then
        For Each Dossier In Dossier.SubFolders
            ListeFichiersDossier Dossier.Path, True
        Next Dossier
    End If
 
    Set Dossier = Nothing
    Set FSO = Nothing
End Sub