XL 2010 Copier un fichiers txt qui ont le même nom de plusieurs sous-dossiers vers un dossier

Option Explicit

Sub Test()
    Call FichiersSousRépertoires("H:\Téléchargements")
End Sub

'---------------------------------------------
'Fichiers des sous-répertoires d'un répertoire
'---------------------------------------------
Sub FichiersSousRépertoires(NomRépertoire As String)
    Dim oFSO As Object
    Dim oDir As Object
    Dim oSubDir As Object
    Dim oFile As Object

    'File System Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")

    'Directory Object
    Set oDir = oFSO.GetFolder(NomRépertoire)

    'Parcours des sous-répertoires du répertoire
    For Each oSubDir In oDir.SubFolders
        'Parcours des fichiers du sous-répertoire       
        For Each oFile In oSubDir.Files
            Call TraiteFichier(oSubDir.Path, oFile.Name, oFile.Path)
        Next oFile
    Next oSubDir
End Sub

'-----------------------
'Traitement d'un fichier
'-----------------------
Sub TraiteFichier(NomRépertoire As String, NomFichier As String, NomCompletFichier As String)
    MsgBox "Traitement <" & NomRépertoire & "\" & NomFichier & ">"
End Sub

If Right(NomFichier, 4) = ".txt" then
<traitement du fichier>
End If

Filecopy NomCompletFichier, "C:\Users\...\destination\"" & " date()".txt"

FileCopy NomCompletFichier, "C:\Users\...\destination\" & NomRépertoire & ".txt"

'-----------------------
'Traitement d'un fichier
'-----------------------

Sub TraiteFichier(NomRépertoire As String, NomFichier As String, NomCompletFichier As String)
    Const RépertoireDestination = "C:\Users\Youssef\Documents\fansub\testmacro\Destination\"
    If NomFichier = "XXXX.txt" Then
        FileCopy NomCompletFichier, RépertoireDestination & NomRépertoire & "-" & Format(Date, "yyyy-mm-dd") & ".txt"
    End If
End Sub

'patricktoulon
'basée sur ma fonction récursive avec dir de 2016
'tout les fichiers "XXXX.txt" seront trouvé et listés
Option Explicit
Sub testXy()
    Cells.Clear
    Dim liste As Variant, i&
    liste = listefichier("C:\Users\polux\DeskTop\dossier maitre\", partname:="XXXX", extention:=".txt")

    'maintenant  tu fait ce que tu veux avec la liste des fichiers trouvés
    ' exemple
    MsgBox Join(liste, vbCrLf)

    For i = LBound(liste) To UBound(liste)
        'te reste plus qu'a faire un filecopy ici dans la boucle
        '...

    Next

End Sub

Function listefichier(Dossier As String, Optional recall As Boolean = False, Optional tbl As Variant, Optional partname As String = "*", Optional extention As String = "*") As Variant
    Dim ItemVu As String, directory As Variant, SubFolderCollection As Collection, i As Long, A As Long, E As Long, subdossier
    Set SubFolderCollection = New Collection
    If recall = False Then ReDim tbl(0)    ' si recall  on redim un tableau  de zero item (pour la creation du tableau)
    On Error Resume Next    'gestion des fichiers dossiers system et interdit ou generant une erreur(PerLog,recycle,etc..)
    ItemVu = Dir(Dossier, vbDirectory)
    If Error.Number = 0 Then    ' si pas d'erreur on examine le contenu
        'examen  du dossier courrant
        Do Until ItemVu = vbNullString
            If Left(ItemVu, 1) <> "." Then
                If (GetAttr(Dossier & ItemVu) And vbDirectory) = vbDirectory Then
                    SubFolderCollection.Add ItemVu
                Else
                    If Left(ItemVu, Len(partname)) = partname And Right(ItemVu, 4) = extention Then A = UBound(tbl) + 1: ReDim Preserve tbl(1 To A): tbl(A) = Dossier & ItemVu

                End If
            End If
            ItemVu = Dir()
        Loop
    Else
        Err.Clear
    End If
    'examen des sub dossier
    For Each subdossier In SubFolderCollection
        'A = UBound(tbl) + 1: ReDim Preserve tbl(1 To A): tbl(A) = Dossier & subdossier' si on veut lister les dossiers aussi
        listefichier Dossier & subdossier & "\", True, tbl, partname, extention
    Next subdossier
    listefichier = tbl
End Function