Macro copie de données de différents dossiers

Public FeuilleDestination As Worksheet    
'Activer la référence "Microsoft scripting runtime" pour que la macro foncitonne    



'Parcours les sous-dossiers inclus dans le répertoire "résultats"    
Sub ListeDossiersResultats()    
    'Adapté de Ole P Erlandsen    
    Application.ScreenUpdating = False    
        Dim Fso As Object, SourceFolder As Object    
    Dim SubFolder As Object    
    Dim NomRep As String    
    Dim NomSousRepComplet As String    
     
    NomRep = "D:\Mes documents\Cours master 1\mémoire2\résultats" 'Nom du répertoire parent    
        
       
    Set Fso = CreateObject("Scripting.FileSystemObject")    
    Set SourceFolder = Fso.GetFolder(NomRep)    
        
    For Each SubFolder In SourceFolder.SubFolders    
    NomSousRepComplet = SubFolder.Path    
          
        SelectionDonneesVariables (NomSousRepComplet)    
                    
    Next SubFolder    
    Application.ScreenUpdating = True    

MsgBox ("Liste terminée")    

End Sub    


     

Sub SelectionDonneesVariables(NomSousRepComplet As String)    

Dim fs, F, f1, s, sf    
Dim i As Long, Fin As Long    
Set FeuilleDestination = ThisWorkbook.Sheets("Traitement")    
    Set fs = CreateObject("Scripting.FileSystemObject")    
    Set F = fs.GetFolder(NomSousRepComplet)    
    Set sf = F.Files    
    For Each f1 In sf    
        If LCase(Right(f1.Name, 3)) = "xlsx" Then    
            Fichier = NomSousRepComplet & "\" & f1.Name    
            Workbooks.Open Filename:=Fichier    
            Range("B3:C3").Select    
            Selection.Copy Destination:=FeuilleDestination.Range("A2:B2")    
            Range("E6").Select    
            Selection.Copy Destination:=FeuilleDestination.Range("C2")    
            Range("K7").Select    
            Selection.Copy Destination:=FeuilleDestination.Range("D2")    
            Range("K4").Select    
            Selection.Copy Destination:=FeuilleDestination.Range("E2")    
            Range("K6").Select    
            Selection.Copy Destination:=FeuilleDestination.Range("F2")    
            Range("K5").Select    
            Selection.Copy Destination:=FeuilleDestination.Range("G2")    
            ActiveWindow.Close SaveChanges:=False    
            'Appel la procédure d'enregistrement    
            Sauv_traitement (Fichier)    
        End If    
    Next    

End Sub    
Sub Sauv_traitement(Fichier)    
'    
' Sauv_traitement Macro    
'    

   Windows("Résumé résultats vérification respect des conditions.xlsm:2").Activate    
        
    Windows("Résumé résultats vérification respect des conditions.xlsm:1").Activate    
    Selection.Copy    
    Windows("Résumé résultats vérification respect des conditions.xlsm:2").Activate    
    ActiveCell.Offset(1, 0).Range("A1").Select    
    ActiveSheet.Paste    
End Sub