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

Option Explicit

Sub TestFichiersRépertoireDIR()
    Dim X
    Const Répertoire = "H:" ' "H:\Téléchargements"
    X = FichiersRépertoireDIR(Répertoire)
[A1].Resize(UBound(X)) = Application.Transpose(X)

End Sub

'-------------------------------------------------------------
'Liste des fichiers de l'arborescence complète d'un répertoire
'-------------------------------------------------------------
Function FichiersRépertoireDIR(ByVal NomRépertoire As String, Optional NoRecycle As Boolean = True) As Variant
    Static TabNomsFichiers() As String
    Static NbFichiers As Long
    Dim TabSubFolders() As String
    Dim NbSubFolders As Long
    Dim NomItem As String
    Dim i As Long, q As Long
    Dim Bool As Boolean
    Dim ErrNumber As Variant
    Dim arr1, arr2
    arr1 = Array("a^", "a¨", "a`", "e^", "e¨", "i^", "i¨")
    arr2 = Array("â", "ä", "à", "ê", "ë", "î", "ï")
    'Appel recursif de cette fonction
    If Left(NomRépertoire, 1) = "|" Then
        NomRépertoire = Mid(NomRépertoire, 2)
    'Appel initial
    Else
        Erase TabNomsFichiers
        NbFichiers = 0
    End If
    
    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
        'L'item est un répertoire
        On Error Resume Next
        Bool = False
        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
            Else
                NbSubFolders = NbSubFolders + 1
                ReDim Preserve TabSubFolders(1 To NbSubFolders)
                TabSubFolders(NbSubFolders) = NomItem
            End If
        
        'L'item est un fichier
        Else
           For q = 0 To UBound(arr1): NomItem = Replace(Replace(NomItem, arr1(q), arr2(q)), UCase(arr1(q)), UCase(arr2(q))): Next
            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
    
    For i = 1 To NbSubFolders
        'Appels recursifs idntifiés par "|" en début du nom de répertoire
        Call FichiersRépertoireDIR("|" & NomRépertoire & TabSubFolders(i), NoRecycle:=NoRecycle)
    Next i
    
    'Return value
    FichiersRépertoireDIR = TabNomsFichiers
End Function

    Const AccentsKO = "a~,a`,a^,a¨,e`,e^,e¨,i`,i^,i¨,o~,o`,o^,o¨,u`,u^,u¨"
    Const AccentsOK = "ã,à,â,ä,è,ê,ë,ì,î,ï,õ,ò,ô,ö,ù,û,ü"
    Dim TabAccentsKO() As String
    Dim TabAccentsOK() As String
    TabAccentsKO = Split(AccentsKO, ",")
    TabAccentsOK = Split(AccentsOK, ",")

        'L'item est un fichier
        Else
            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
            End If

 If Not IsArray(Table) Then
        MsgBox "Aucun fichier"
    Else
        [A2].Resize(UBound(Table)) = Application.Transpose(Table)
    End If

 'Return value
    FichiersRépertoireDIR = vbNull
    If NbFichiers > 0 Then FichiersRépertoireDIR = TabNomsFichiers

Sub TestFichiersRépertoireFSO()
    Dim Table As Variant
    Const Répertoire = "H:" ' "H:\Téléchargements"
    
    Table = FichiersRépertoireFSO(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 & ">"
        ActiveSheet.Range("B2:B" & Rows.Count).ClearContents
        ActiveSheet.Range("B2").Resize(UBound(TableFichiers)).Value = Application.Transpose(TableFichiers)
    Else
        MsgBox "Aucun fichier dans le répertoire <" & Répertoire & ">"
    End If
End Sub

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