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

Sub test()
    Dim racine$
    racine = "H:"
    tableau = recherche_récursive(racine)
    Cells(1, 1).Resize(UBound(tableau) + 1, 1) = Application.Transpose(tableau)
End Sub
'
'
Private Function recherche_récursive(dparent, Optional L As String) As Variant
    Dim FSO As Object, Lparent As Object, SubFolder As Object, Ficher
    Set FSO = CreateObject("scripting.filesystemobject")    ' on declare l'object
    ' regard sur les fichiers
    Set Lparent = FSO.GetFolder(dparent)    'on attribue a l'object.getfolder le dossier demandé 'Scripting.Folder
      '-------------------------------------------------------------
     'condition garde fou pour fichier ou dossiers non autorisé
    If Not Lparent Like "*RECYCLE.*" And Not Lparent Like "BIN\" And Not Lparent Like "*System Volume Information*" Then
     '----------------------------------------------------------------
        For Each Ficher In Lparent.Files    'on boucle sur les fichiers qui sont dans ce dossier
            L = L & Ficher & vbCrLf
        Next
        'boucles sur les sous dossiers
        For Each SubFolder In Lparent.SubFolders    'on boucle sur les dossiers qui sont dans ce dossiers
            'L = L & SubFolder.Path & vbCrLf
            recherche_récursive SubFolder.Path, L   ' on rappelle la fonction avec pour argument le chemin du sous dossier ainsi que l'extension et L qui est déjà peut être remplie
        Next SubFolder
    End If

    recherche_récursive = Split(L, vbCrLf)    'on coupe la liste par les saut de lignes on a maintenant un array la fonction devient cet array
End Function

Sub test()
    Dim racine$, tim
    ReDim t(1 To 1)    'on dimentionne un array de 1 item pour commencer
    racine = "H:"    ' disque à lister
    tim = Timer
    recherche_récursive racine, t    'appel de la fonction t est injecté comme tel
    MsgBox (Timer - tim) & " secondes ; " & UBound(t) & " fichiers"
    Cells(1, 1).Resize(UBound(t), 1) = Application.Transpose(t)
End Sub
'
'
Private Function recherche_récursive(dparent, t, Optional L As String)    ' As Variant
    Dim FSO As Object, Lparent As Object, SubFolder As Object, Ficher, a
    Set FSO = CreateObject("scripting.filesystemobject")    ' on declare l'object
    Set Lparent = FSO.GetFolder(dparent)  ' regard sur les fichiers  'on attribue a l'object.getfolder le dossier demandé 'Scripting.Folder
    '-------------------------------------------------------------
    'condition garde fou pour fichier ou dossiers non autorisé
    If Not Lparent Like "*RECYCLE.*" And Not Lparent Like "BIN\" And Not Lparent Like "*System Volume Information*" Then
        '----------------------------------------------------------------
        For Each Ficher In Lparent.Files    'on boucle sur les fichiers qui sont dans ce dossier
            a = UBound(t) + 1: ReDim Preserve t(1 To a): t(a) = Ficher    ' on redim preserve le tableau(t) avec un item de plus et on instruit l'item avec le chemin de fichier trouvé
        Next
        For Each SubFolder In Lparent.SubFolders    'on boucle sur les dossiers qui sont dans ce dossiers
            'a = UBound(t) + 1: ReDim Preserve t(1 To a): t(a) = SubFolder.Path 'SI ON LISTE AUSSI LES DOSSIERS , on redim preserve le tableau(t) avec un item de plus et on instruit l'item avec le chemin de dossier trouvé
            recherche_récursive SubFolder.Path, t, L  ' on rappelle la fonction avec pour argument le chemin du sous dossier ainsi que le tableau(t) pour continuer a l'instruire
        Next SubFolder
    End If
  End Function

Sub testQ()
    Dim racine$, tim
    ReDim t(1 To 1)    'on dimentionne un array de 1 item pour commencer
    racine = "H:"    ' disque à lister
    tim = Timer
    recherche_récursive racine, t    'appel de la fonction t est injecté comme tel
    MsgBox (Timer - tim) & " secondes ; " & UBound(t) & " fichiers"
    Cells(1, 1).Resize(UBound(t), 1) = Application.Transpose(t)
End Sub
'
'
Private Function recherche_récursive(dparent, t, Optional L As String)    ' As Variant
    Dim FSO As Object, Lparent As Object, SubFolder As Object, Ficher, a
    Set FSO = CreateObject("scripting.filesystemobject")    ' on declare l'object
    Set Lparent = FSO.GetFolder(dparent)  ' regard sur les fichiers  'on attribue a l'object.getfolder le dossier demandé 'Scripting.Folder
    '-------------------------------------------------------------
    'condition garde fou pour fichier ou dossiers non autorisé
    If Not Lparent Like "*RECYCLE.*" And Not Lparent Like "BIN\" And Not Lparent Like "*System Volume Information*" Then
        '----------------------------------------------------------------
        For Each Ficher In Lparent.Files    'on boucle sur les fichiers qui sont dans ce dossier
            a = UBound(t) + 1: ReDim Preserve t(1 To a): t(a) = Ficher    ' on redim preserve le tableau(t) avec un item de plus et on instruit l'item avec le chemin de fichier trouvé
        Next
        For Each SubFolder In Lparent.SubFolders    'on boucle sur les dossiers qui sont dans ce dossiers
            'a = UBound(t) + 1: ReDim Preserve t(1 To a): t(a) = SubFolder.Path 'SI ON LISTE AUSSI LES DOSSIERS , on redim preserve le tableau(t) avec un item de plus et on instruit l'item avec le chemin de dossier trouvé
            recherche_récursive SubFolder.Path, t, L  ' on rappelle la fonction avec pour argument le chemin du sous dossier ainsi que le tableau(t) pour continuer a l'instruire
        Next SubFolder
    End If
    'recherche_récursive = t   'a la fin la fonction devient le tableau (t)
End Function


'--------------------------------------------------------
Sub testzzzzz()
    Dim racine$, tim
    ReDim t(1 To 1)    'on dimentionne un array de 1 item pour commencer
    racine = "H:"    ' disque à lister
    tim = Timer
    recherche_récursive2 racine, t, ".txt"   'appel de la fonction t est injecté comme tel
    MsgBox (Timer - tim) & " secondes ; " & UBound(t) & " fichiers"
    Cells(1, 1).Resize(UBound(t), 1) = Application.Transpose(t)
End Sub
'
'
Private Function recherche_récursive2(dparent, t, Optional ext As String = "*")  ' As Variant
    Dim FSO As Object, Lparent As Object, SubFolder As Object, Ficher, a
    Set FSO = CreateObject("scripting.filesystemobject")    ' on declare l'object
    Set Lparent = FSO.GetFolder(dparent)  ' regard sur les fichiers  'on attribue a l'object.getfolder le dossier demandé 'Scripting.Folder
    '-------------------------------------------------------------
    'condition garde fou pour fichier ou dossiers non autorisé
    If Not Lparent Like "*RECYCLE.*" And Not Lparent Like "BIN\" And Not Lparent Like "*System Volume Information*" Then
        '----------------------------------------------------------------
        For Each Ficher In Lparent.Files    'on boucle sur les fichiers qui sont dans ce dossier
           If Right(Ficher, Len(ext)) Like ext Then a = UBound(t) + 1: ReDim Preserve t(1 To a): t(a) = Ficher    ' on redim preserve le tableau(t) avec un item de plus et on instruit l'item avec le chemin de fichier trouvé
        Next
        For Each SubFolder In Lparent.SubFolders    'on boucle sur les dossiers qui sont dans ce dossiers
            'a = UBound(t) + 1: ReDim Preserve t(1 To a): t(a) = SubFolder.Path 'SI ON LISTE AUSSI LES DOSSIERS , on redim preserve le tableau(t) avec un item de plus et on instruit l'item avec le chemin de dossier trouvé
            recherche_récursive SubFolder.Path, t, ext  ' on rappelle la fonction avec pour argument le chemin du sous dossier ainsi que le tableau(t) pour continuer a l'instruire
        Next SubFolder
    End If
    'recherche_récursive = t   'a la fin la fonction devient le tableau (t)
End Function