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

Option Compare Text
Sub testFSO()
    [A1].CurrentRegion.ClearContents
    Dim Racine$, tim, Ext$, T
    Racine = "h:\"    ' disque à lister
    tim = Timer
    Ext = "*.txt"    ' une partie du nom  et l'extension
    'T = recherche_récursive1(Racine)                             'tout les fichiers
    'T = recherche_récursive1(Racine, withdolder:=True)           ' atout les fichiers et leur dossier parent
    T = recherche_récursive1(Racine, Ext)                        ' avec extention "*.txt"
    'T = recherche_récursive1(Racine, Ext, withdolder:=True)      ' avec extention "*.txt" et leur dossier parent
    MsgBox (Timer - tim) & " secondes ; " & UBound(T) & " fichiers avec FSO"
    If UBound(T) > 0 Then Cells(1, 1).Resize(UBound(T), 1) = T
End Sub
'
'
Private Function recherche_récursive1(dparent As String, Optional E As String = "", Optional recall As Boolean = False, Optional WithFolder As Boolean = False)   ' As Variant
    Static FSO As Object: Static T$(): Dim Lparent As Object, SubFolder As Object, Ficher, TakeIT As Variant, x

    If Not recall Then ReDim T(0): Set FSO = CreateObject("scripting.filesystemobject")    ' on declare l'object
    Set Lparent = FSO.GetFolder(dparent)

    'If Lparent.Name = "$RECYCLE.BIN" Or Lparent.Name = "System Volume Information" Then Exit Function
    '4 secondes environ supplementaires sur le disque H en entiere et plus selon le nombre de fichiers dans la poubelle
    TakeIT = True
    If E <> "" Then
        On Error Resume Next
        TakeIT = Dir(Lparent.Path & "\" & E) <> vbNullString
        If Err.Number > 0 Then Err.Clear: TakeIT = False
    End If

    If TakeIT Then
        If WithFolder Then ReDim Preserve T(UBound(T) + 1): T(UBound(T) - 1) = Lparent.Path
        On Error Resume Next
        For Each Ficher In Lparent.Files
            If Err.Number = 0 Then
                If E <> "" Then
                    If Ficher.Name Like E Then ReDim Preserve T(UBound(T) + 1): T(UBound(T) - 1) = Ficher:
                Else
                    ReDim Preserve T(UBound(T) + 1): T(UBound(T) - 1) = Ficher:
                End If
            End If
            Err.Clear
        Next
    End If

    On Error Resume Next
    For Each SubFolder In Lparent.subfolders
        If Err.Number = 0 Then recherche_récursive1 SubFolder.Path & "\", E, True, WithFolder
        Err.Clear:
    Next SubFolder

    If Not recall Then
        ReDim tbl(UBound(T), 1 To 1)
        For I = LBound(T) To UBound(T): tbl(I, 1) = T(I): Next
        recherche_récursive1 = tbl
    End If
End Function