Macro copie de données de différents dossiers

Bonjour,



je souhaite automatiser la récupération de données de différents fichiers xlsx des différent sous répertoire :
- résultats:
...............- condition 2 :
.....................................- cl : -1.xlsx
............................................ - 2.xlsx ...
.............. - condition 3 :
.....................................- cl : - 11.xlsx
.............................................- 21.xlsx ...
...............- condition 3 :
.....................................- cl : - 12.xlsx
.............................................- 22.xlsx ...

pour les copier dans une feuille excel tel que :

expl:
donnée1,,donnée2,,donnée3,,...
233525. ,,.365351.,,.354561.,,...
325468. ,,.125468.,,.325457.,,...

j'ai écrit ce code à partir d'un autre code que "Syzygy" m'a gentiment écrit, mais ça ne marche pas. Quelqu'un peut m'expliquer pourquoi et m'aider faire que ça marche ?


Le code:

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    

______________________________________________________________

Merci