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

'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&, OldDossier, newdossier
    liste = listefichier("C:\Users\polux\DeskTop\dossier maitre\", partname:="XXXX", extention:=".txt")
    newdossier = "C:\Users\polux\DeskTop\nouveau dossier maitre\"

    '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)
        OldDossier = Split(liste(i), "\")(UBound(Split(liste(i), "\")) - 1)
      
        MsgBox "le fichier s'appelle " & liste(i) & vbCrLf & "il devrait s'appeler maintenant" & vbCrLf & newdossier & OldDossier & ".txt"
        '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

Sub testX()
    Cells.Clear
    Dim liste As Variant
    liste = DirList("H:\")
    Cells(1, 1).Resize(UBound(liste), 1).Value = Application.Transpose(liste)
End Sub

Function DirList(Dossier As String, Optional recall As Boolean = False, Optional tbl As Variant) As Variant
    Dim ItemVu As String, directory As Variant, SubFolderCollection As Collection, I As Long, A As Long, E As Long
    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
                    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
        DirList Dossier & subdossier & "\", True, tbl
    Next subdossier
    DirList = tbl
End Function

criteres = vbDirectory Or vbSystem Or vbHidden Or vbArchive Or ReadOnly Or vbNormal