VBA-Résultat de diff. fichiers dans 1 fichier

Option Explicit

Private myTabFile()
Private Const dossier = "C:\Temp"  'Mettre ici le chemin du répertoire qui contient les fichiers xls

Public Sub Main()
Dim i As Long
Dim ValCell As Variant
Dim mDate As String
Dim lig As Long

    If ModTools.AllFilesInFolder(dossier, myTabFile(), "xls") = False Then
        MsgBox "Merci de vérifier le chemin d'accès au dossier.", vbExclamation, "Erreur"
        Exit Sub
    End If
    
    For i = LBound(myTabFile()) To UBound(myTabFile())
        If InStr(1, myTabFile(i), "Prix_") <> 0 Then
            ValCell = ModCnx.ExtractCellValue(myTabFile(i))
            mDate = ModTools.ExtractFileName(myTabFile(i))
            mDate = ModTools.returnDateFile(mDate)
            lig = 2
            ThisWorkbook.Worksheets(1).Range("A" & lig).Value = mDate
            ThisWorkbook.Worksheets(1).Range("B" & lig).Value = ValCell
            lig = lig + 1
        End If
    Next i
    
End Sub

Option Explicit

'/!\ NECESSITE LA REFERENCE Microsoft Scripting Runtime

Public Function AllFilesInFolder(ByVal NomDossier As String, ByRef myTab, Optional ByVal ExtentionType As String) As Boolean
Dim fso As Object, dossier As Object, Fich As Object
Dim Files As Object, File As Object
Dim max As Long, ext As String

    'Initialisation du tableau
    ReDim myTab(0)
    '
    ' Création de l'objet FSO
    On Error Resume Next ' AllFilesInFolder_Error

    Set fso = CreateObject("Scripting.FileSystemObject")
    ' Si le nom du dossier est vide, alors je sort de la fonction
    If NomDossier = "" Then Exit Function
    ' Stock les sous-répértoires dans l'objet dossier
    Set dossier = fso.GetFolder(NomDossier)
    
    ' stock dans l'objet Files tous les fichiers de l'objet dossier
    Set Files = dossier.Files
    ' s'il y a plus d'un fichier
    If Files.Count <> 0 Then
        max = 0
        ' pour tous les objets fichiers dans l'objet files
        For Each File In Files
          '
          ' je récupère le nom du fichier via l'objet Fich
          Set Fich = fso.GetFile(File)
          ' si l'extension n'est pas renseignée
          ext = ExtentionType
          If ExtentionType = "" Then ext = fso.GetExtensionName(File)
          '
          If UCase(fso.GetExtensionName(File)) = UCase(ext) Then
            max = max + 1
            ' j'augmente la taille de mon tableau résultat
            ReDim Preserve myTab(1 To max)
            ' Je stock en fin de tableau mon nom de fichier
            myTab(max) = File
          End If
        Next
    End If
    '
    ' Libère tous les objets
    Set fso = Nothing
    Set dossier = Nothing
    Set Fich = Nothing
    Set Files = Nothing
    Set File = Nothing
    '
    
    If Err.Number = 0 Then
        AllFilesInFolder = True
        Exit Function
    Else
        AllFilesInFolder = False
    End If
End Function

Public Function ExtractFileName(ByVal sFullPath As String) As String
    If InStr(sFullPath, "\") = 0 Or Right(sFullPath, 1) = "\" Then
        ExtractFileName = ""
        Exit Function
    End If
    ExtractFileName = Mid(sFullPath, InStrRev(sFullPath, "\") + 1)
End Function


Public Function returnDateFile(ByVal str As String) As String
Dim tmp As String
Dim tmp2 As String

    tmp = Mid(str, 6, 6)
    tmp2 = Mid(tmp, 5, 6) & "/"
    tmp2 = tmp2 & Mid(tmp, 3, 2) & "/"
    tmp2 = tmp2 & Mid(tmp, 1, 2)
    
    returnDateFile = Format(tmp2, "dd mmmm yyyy")
    
End Function

Option Explicit
'/!\ NECESSITE LA REFERENCE Microsoft ActivX Data Objects x.x Library


Private cnx As ADODB.Connection
Private Rst As ADODB.Recordset
Private ADOCommand As ADODB.Command

Public Function ExtractCellValue(ByVal nomFile As String)
Dim feuille As String
Dim cellule As String

    feuille = "Feuil1$"      'Mettre ici le nom de feuille où récupérer la cellule I7. 
                                    'Attention de bien mettre le signe $ en fin de nom
    cellule = "I7:I7"
    
    Set cnx = New ADODB.Connection
    cnx.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & nomFile & ";Extended Properties=""Excel 8.0;HDR=No;"";"
                
    Set ADOCommand = New ADODB.Command
    With ADOCommand
        .ActiveConnection = cnx
        .CommandText = "SELECT * FROM [" & feuille & cellule & "]"
    End With
                  
    Set Rst = New ADODB.Recordset
    Rst.Open ADOCommand, , adOpenKeyset, adLockOptimistic
                  
    Set Rst = cnx.Execute("[" & feuille & cellule & "]")
    
    ExtractCellValue = Rst.Fields(0)
    
    Rst.Close
    cnx.Close
    
    Set Rst = Nothing
    Set cnx = Nothing
    Set ADOCommand = Nothing
    
End Function