Macro sur fichiers dans dossiers séparés

 Sub PrintFolders()
Dim objFSO As Object
Dim objFolder As Object
Dim objSubFolder As Object
Dim i As Integer

Dim Wb As Workbook
Dim strFile As String
Dim strDir As String

Dim fdest As Worksheet, fsource As Worksheet
Dim dlig As Long
Dim sfich As String
Dim srow As Range
Dim crit1$, crit2$, crit3$
Dim skey, sval, cpath As String

cpath = ThisWorkbook.Path & "\"
Set fdest = ActiveSheet
crit1 = fdest.Cells(1, 2)
crit2 = fdest.Cells(1, 3)
crit3 = fdest.Cells(1, 4)

dlig = 2

Application.StatusBar = ""
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder("C:\Users\Macro_test\")
i = 1
'loops through each folder in the directory and prints their names and path
For Each objSubFolder In objFolder.subfolders
Application.StatusBar = objSubFolder.Path & " " & objSubFolder.Name
    'print folder name
    strDir = objSubFolder.Path
    strFile = strDir & "\informations.txt"
    'Loop
    
    Do While strFile <> ""
    Set Wb = Workbooks.Open(strFile, Format:=6, Delimiter:=",")
          'Save it as Excel file, same name as text file
        Wb.SaveAs Left(strFile, InStrRev(strFile, ".") - 1), xlWorkbookDefault
          'Done
        Wb.Close
        Set Wb = Nothing
    Set Wb = Workbooks.Open(strDir & "\informations.xlsx")
    Set fsource = Wb.Sheets(1)
        For Each srow In fsource.UsedRange.Rows
            skey = srow.Cells(1, 1)
            sval = srow.Cells(1, 2)
            Select Case skey
                Case Is = crit1
                    fdest.Cells(dlig, 2) = sval
                Case Is = crit2
                    fdest.Cells(dlig, 3) = sval
                Case Is = crit3
                    fdest.Cells(dlig, 4) = sval
            End Select
        Next srow
        Wb.Close
        dlig = dlig + 1
        sfich = fdest.Cells(dlig, 1)
        Exit Do
    Loop

    Cells(i + 1, 1) = objSubFolder.Name
    i = i + 1
    
Next objSubFolder

End Sub