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

Option Explicit
'patricktoulon dir fichier fonction récursive
Sub testDIR()
    Dim tim#, t
    tim = Timer
    t = DirList("h:\")
    If IsArray(t) Then
        MsgBox Timer - tim & " secondes pour " & UBound(t) & " fichier(s)"
        [A1].Resize(UBound(t)) = Application.Transpose(t)
    Else
        MsgBox "pas de fichier"
    End If
End Sub

Function DirList(Dossier As String, Optional recall As Boolean = False) As Variant
    Dim ItemVu As String, SubFolderCollection As New Collection, i As Long, a As Long, q As Long, criteres, arr1, arr2, subdossier
    Static tbl$() 'tbl est désormais statique il ne se balade plus dans les appels récursifs
    arr1 = Array("a~", "a`", "a^", "a¨", "e`", "e^", "e¨", "i`", "i^", "i¨", "o~", "o`", "o^", "o¨", "u`", "u^", "u¨")    'array caracteres séparés
    arr2 = Array("ã", "à", "â", "ä", "è", "ê", "ë", "ì", "î", "ï", "õ", "ò", "ô", "ö", "ù", "û", "ü")    'array caracteres regroupés
    If recall = False Then ReDim tbl(1 To 1)    ' si recall  on redim un tableau  de zero item (pour la creation du tableau)
    criteres = vbDirectory Or vbSystem Or vbHidden    ' Or vbArchive Or ReadOnly Or vbNormal
    On Error Resume Next    'gestion des fichiers dossiers system et interdit ou generant une erreur(PerLog,recycle,etc..)
    ItemVu = Dir(Dossier, criteres)
    If Error.Number = 0 Then    ' si pas d'erreur on examine le contenu
        'examen  du dossier courrant
        Do While ItemVu <> vbNullString    'boucle tant que DIR renvoie une chaine
            If ItemVu <> "." And ItemVu <> ".." Then
                On Error Resume Next
                If (GetAttr(Dossier & ItemVu) And vbDirectory) = vbDirectory Then    'test Dossier
                    If Err.Number > 0 Then    'si erreur c'est un fichier(particulier ou caractères particulier)
                        For q = 0 To UBound(arr1): ItemVu = Replace(Replace(ItemVu, arr1(q), arr2(q)), UCase(arr1(q)), UCase(arr2(q))): Next    'replace caracteres
                        ReDim Preserve tbl(1 To a): tbl(a) = Dossier & ItemVu: a = UBound(tbl) + 1    'ajout dans la liste
                    Else: SubFolderCollection.Add Dossier & ItemVu: Err.Clear    'sinon ajout dans la collection de dossier
                    End If
                Else'sinon c'est un fichier et pas un concombre:)
                    a = UBound(tbl) + 1: ReDim Preserve tbl(1 To a): tbl(a) = Dossier & ItemVu    'ajout fichier dans la liste
                End If
            End If
            ItemVu = Dir()
        Loop
    Else
        Err.Clear
    End If
    'examen des sub dossier appel récursif
    For Each subdossier In SubFolderCollection
        DirList subdossier & "\", True
    Next subdossier
    DirList = False
    If SubFolderCollection.Count > 0 Then DirList = tbl  ' return du tableau (après le dernier appel récursif )'économie de 0.3000 secondes
End Function

Sub testFSO()
    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)    ' 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
        If Lparent.SubFolders.Count Then
            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  ' 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 If
    'recherche_récursive = t   'a la fin la fonction devient le tableau (t)
End Function

Option Explicit

Sub TestFichiersRépertoireDIR()
    Dim Table As Variant, tim#
    Const Répertoire = "H:" ' "H:\Téléchargements"
    tim = Timer
    Table = FichiersRépertoireDIR(Répertoire)
    
    'If not VarType(Table) = vbBoolean Then
    If IsArray(Table) Then
        MsgBox UBound(Table) & " fichier(s) trouvé(s) dans le répertoire <" & Répertoire & "> en " & Timer - tim & " secondes"
        ActiveSheet.Range("A2:A" & Rows.Count).ClearContents
    ActiveSheet.Range("A2").Resize(UBound(Table)).Value = Application.Transpose(Table)
    Else
        MsgBox "Aucun fichier dans le répertoire <" & Répertoire & ">"
    End If
End Sub

'---------------------------------------------------------------
'Liste des fichiers de l'arborescence complète d'un répertoire
'par la "méthode Dir()"
'
'- NomRépertoire: chaine du nom du répertoire concerné
'                 (avec ou sans '\' final)
'- NoRecycle: True (valeur par défaut) pour ne pas avoir les
'             fichiers de la poubelle dans la liste résultat
'             si NomRépertoire est une lettre de lecteur (drive)
'- Return: table à 1 dimension des noms complets des fichiers
'          ou False si aucun fichier dans le répertoire
'---------------------------------------------------------------
Function FichiersRépertoireDIR(ByVal NomRépertoire As String, Optional NoRecycle As Boolean = True) As Variant
    'Tableau résultat static pour être indépendant des appels récursifs
    Static TabNomsFichiers() As String
    Static NbFichiers As Long
    
    'Variables pour la gestion des problèmes d'accents sur les noms de fichiers retournés par Dir()
    Const AccentsKO = "a~,a`,a^,a¨,e`,e^,e¨,i`,i^,i¨,o~,o`,o^,o¨,u`,u^,u¨"
    Const AccentsOK = "ã,à,â,ä,è,ê,ë,ì,î,ï,õ,ò,ô,ö,ù,û,ü"
    Static TabAccentsKO() As String
    Static TabAccentsOK() As String
    
    'Variable spécifiques à une instance de la fonction
    Dim TabSubFolders() As String
    Dim NbSubFolders As Long
    Dim NomItem As String
    Dim i As Long
    Dim q As Long
    Dim Bool As Boolean
    Dim ErrNumber As Variant
    Dim InitialCall As Boolean
    
    'Appel recursif de cette fonction (par elle-même ci-dessous)
    If Left(NomRépertoire, 1) = "|" Then
        InitialCall = False
        NomRépertoire = Mid(NomRépertoire, 2)
    'Appel initial
    Else
        InitialCall = True
        'Table résultat
        Erase TabNomsFichiers
        NbFichiers = 0
        'Tables des accents
        TabAccentsKO = Split(AccentsKO, ",")
        TabAccentsOK = Split(AccentsOK, ",")
    End If
  
    'Complémente éventuellement le nom du répertoire avec '\'
    If Right(NomRépertoire, 1) <> "\" Then NomRépertoire = NomRépertoire & "\"
  
    '1er item dans le répertoire
    On Error Resume Next
    NomItem = Dir(NomRépertoire, vbDirectory Or vbSystem Or vbHidden)
    ErrNumber = err.Number
    On Error GoTo 0
    If ErrNumber <> 0 Then Exit Function
  
    Do While Len(NomItem) > 0
        Bool = False
        On Error Resume Next
        Bool = (GetAttr(NomRépertoire & NomItem) And vbDirectory) = vbDirectory
        ErrNumber = err.Number
        On Error GoTo 0
      
        'L'item est un répertoire
        If Bool Then
            If NomItem = "." Or NomItem = ".." _
            Or NomItem = "System Volume Information" _
            Or (NoRecycle And NomItem = "$RECYCLE.BIN") Then
                'Do nothing
            Else
                NbSubFolders = NbSubFolders + 1
                ReDim Preserve TabSubFolders(1 To NbSubFolders)
                TabSubFolders(NbSubFolders) = NomItem
            End If
      
        'L'item est un fichier
        Else
            'Problème d'accents sur les noms de fichiers retournés par Dir() qui a planté GetAttr()
            If ErrNumber <> 0 Then
                For q = LBound(TabAccentsKO) To UBound(TabAccentsKO)
                    NomItem = Replace(Replace(NomItem, TabAccentsKO(q), TabAccentsOK(q)), UCase(TabAccentsKO(q)), UCase(TabAccentsOK(q)))
                Next q
            End If
            
            'Stocke le nom complet du fichier en table
            NbFichiers = NbFichiers + 1
            ReDim Preserve TabNomsFichiers(1 To NbFichiers)
            TabNomsFichiers(NbFichiers) = NomRépertoire & NomItem
        End If
      
        'Item suivant dans le répertoire
        NomItem = Dir()
    Loop
    
    'Parcours des sous-répertoires du répertoire en cours
    For i = 1 To NbSubFolders
        'Appels recursifs identifiés par "|" en début du nom de répertoire
        Call FichiersRépertoireDIR("|" & NomRépertoire & TabSubFolders(i), NoRecycle:=NoRecycle)
    Next i
  
    'Return value
    If InitialCall Then
        FichiersRépertoireDIR = False
        If NbFichiers > 0 Then FichiersRépertoireDIR = TabNomsFichiers
    End If
End Function

   If recall = False Then DirList = tbl ' return du tableau (apres le dernier appel récursif )'economie de 0.3000 secondes