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

'patricktoulon dir fichier fonction récursive
Option Explicit
Sub testDIR()
    Dim tim#, T
    [A1].CurrentRegion.Clear
    tim = Timer
    T = DirList("c:\")
    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 statique
    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 vbReadOnly 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 = 53 Then
                        If ItemVu Like "*.txt" Then ReDim Preserve tbl(1 To a): tbl(a) = dossier & ItemVu: a = UBound(tbl) + 1:    'ajout fichier dans la liste
                    End If
                    SubFolderCollection.Add dossier & ItemVu    'sinon ajout dans la collection de dossier
                    Err.Clear
                Else    'sinon c'est un fichier et pas un concombre:)
                    If ItemVu Like "*.txt" Then ReDim Preserve tbl(1 To a): tbl(a) = dossier & ItemVu: a = UBound(tbl) + 1:    '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 Not recall Then DirList = tbl  ' return du tableau (apres le dernier appel récursif )'economie de 0.3000 secondes
End Function

if Dir(oDir.Path & "\*." & Extension) <> vbNullString

'Option Explicit

Sub TestFichiersRépertoireFSO()
    Dim Table As Variant, tim#
    Const Répertoire = "c:"    ' "H:\Téléchargements"
    tim = Timer
    'Table = FichiersRépertoireFSO(Répertoire, , "txt")
    Table = FichiersRépertoireFSO(Répertoire, , "txt")

    'If not VarType(Table) = vbBoolean Then
    If IsArray(Table) Then
        Table = TransposeExcel(Table)
        MsgBox UBound(Table) & " fichier(s) trouvé(s) dans le répertoire <" & Répertoire & "> en " & Timer - tim & " s/"
        ActiveSheet.Range("A1:A" & Rows.Count).ClearContents
        ActiveSheet.Range("A1").Resize(UBound(Table)).Value = 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 FileSystemObject"
'
'- 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)
'- Extension: "Pattern" / modèle de l'extension des fichiers à
'             sélectionner ("txt", "xls*" ou "" pour tous)
'- Return: table à 1 dimension des noms complets des fichiers
'          ou False si aucun fichier dans le répertoire
'---------------------------------------------------------------
Function FichiersRépertoireFSO(ByVal NomRépertoire As Variant, _
                               Optional NoRecycle As Boolean = True, _
                               Optional Extension As String = "") As Variant
'Tableau résultat static pour être indépendant des appels récursifs
    Static TabNomsFichiers() As String
    Static NbFichiers As Long

    'Variable du FileSystemObject commune à toutes les instances de la fonction
    Static oFSO As Object

    'Variable spécifiques à une instance de la fonction
    Dim oDir As Object
    Dim oSubDir As Object
    Dim oFile As Object
    Dim InitialCall As Boolean
    Dim TakeIt As Boolean
    Dim NomObjetEnErreur As String
    Dim x As Variant
  
    'Appel recursif de cette fonction (par elle-même ci-dessous)
    If TypeOf NomRépertoire Is Object  Then
        InitialCall = False

        'Valorise l'objet Folder
        Set oDir = NomRépertoire

        'Appel initial
    Else
        InitialCall = True

        'Table résultat
        Erase TabNomsFichiers
        NbFichiers = 0

        'File System Object
        Set oFSO = CreateObject("Scripting.FileSystemObject")

        'Complémente éventuellement le nom du répertoire avec '\'
        If Right(NomRépertoire, 1) <> "\" Then NomRépertoire = NomRépertoire & "\"

        'Valorise l'objet Folder
        Set oDir = oFSO.GetFolder(NomRépertoire)
    End If

    'Si option NoRecycle et répertoire poubelle on ne traite pas
    If (NoRecycle And oDir.Name = "$RECYCLE.BIN") Then Exit Function

    'Si le répertoire est "System Volume Information" on ne traite pas
    If oDir.Name = "System Volume Information" Then Exit Function

    'Vérifie si le répertoire contient des fichiers avec l'extension
    If Len(Extension) = 0 Then
        TakeIt = True
    Else
        TakeIt = True
        'La fonction Dir() introduit des erreurs #52 ou #53 sur les objets Folder
        'de la boucle "For Each oSubDir In oDir.subfolders" ci-dessous.
        'IL NE FAUT PAS L'UTILISER !!!
        'SI SI IL FAUT L UTILISER !!!!!! :):):):)
        On Error Resume Next
        x = True
        x = Dir(oDir.Path & "\*." & Extension) <> vbNullString
        If Err.Number > 0 Or Not x Then TakeIt = False: Err.Clear: x = vbNull
    End If


    'On n'examine les fichiers du répertoire que s'il contient des fichiers avec l'extension
    If TakeIt Then
        On Error Resume Next
        For Each oFile In oDir.Files
            If Err.Number = 0 Then
                'Test si correspondance de l'extension
                If Len(Extension) = 0 Then
                    TakeIt = True
                Else
                    If oFSO.GetExtensionName(oFile.Name) Like Extension Then TakeIt = True Else TakeIt = False
                End If

                'Stocke le nom complet du fichier en table
                If TakeIt Then
                    NbFichiers = NbFichiers + 1
                    ReDim Preserve TabNomsFichiers(1 To NbFichiers)
                    TabNomsFichiers(NbFichiers) = oFile.Path
                End If

                'Fichier en erreur
            Else
                NomObjetEnErreur = "Fichier <"
                If oFile Is Nothing _
                   Then NomObjetEnErreur = NomObjetEnErreur & "Nothing" & ">" _
                   Else NomObjetEnErreur = NomObjetEnErreur & oFile.Name & ">"
                GoSub TraiteErreur
            End If
        Next oFile
        On Error GoTo 0
    End If

    'Parcours des sous-répertoires du répertoire en cours
    On Error Resume Next
    For Each oSubDir In oDir.subfolders
        If Err.Number = 0 Then
            'Appels recursifs identifiés par le type Object de l'argument OsubDir
            Call FichiersRépertoireFSO(oSubDir, NoRecycle, Extension)

            'Répertoire en erreur
        Else
            NomObjetEnErreur = "Répertoire <"
            If oSubDir Is Nothing _
               Then NomObjetEnErreur = NomObjetEnErreur & "Nothing" & ">" _
               Else NomObjetEnErreur = NomObjetEnErreur & oSubDir.Path & ">"
            GoSub TraiteErreur
        End If
    Next oSubDir
    On Error GoTo 0

    'Return value
    If InitialCall Then
        FichiersRépertoireFSO = False
        If NbFichiers > 0 Then FichiersRépertoireFSO = TabNomsFichiers
    End If
    Exit Function

TraiteErreur:
    'Error #70 Authorisation refusée, Error #76 Path not found, Autre erreur à identifier ?
    If Not (Err.Number = 70 Or Err.Number = 76) Then
        MsgBox "FichiersRépertoireFSO erreur #" & Err.Number & vbCrLf & "Sur " & NomObjetEnErreur & ""
    End If
    NomObjetEnErreur = ""
    Err.Clear
    Return
End Function

'--------------------------------------------------------------------
'Fonction de Tranpose selon la logique de WorksheetFunction.Transpose
'sauf que WorksheetFunction.Transpose se limite à 65536 éléments
'alors que cette fonction lève cette limite.
'--------------------------------------------------------------------
Function TransposeExcel(T As Variant) As Variant
    Dim tt() As Variant
    Dim NbDimensions As Integer
    Dim i As Long
    Dim j As Long

    If Not IsArray(T) Then
        MsgBox "Function TransposeExcel: error argument is not an array !"
        Exit Function
    End If

    '1 ou 2 dimensions pour t ?
    On Error Resume Next
    i = UBound(T, 2)
    If Err.Number Then NbDimensions = 1 Else NbDimensions = 2
    On Error GoTo 0

    '------------------------------------------------------
    'Tableau origine 1 dimension
    '=> Tableau destination 2 dimensions dont la 2ème est 1
    '------------------------------------------------------
    If NbDimensions = 1 Then
        ReDim tt(LBound(T) To UBound(T), 1 To 1)

        For i = LBound(T) To UBound(T)
            tt(i, 1) = T(i)
        Next i
    End If

    '----------------------------
    'Tableau origine 2 dimensions
    '----------------------------
    If NbDimensions = 2 Then
        '-----------------------------------------------
        'Tableau origine 2 dimensions dont la 2ème est 1
        '=> Tableau destination 1 dimension
        '-----------------------------------------------
        If UBound(T, 2) = 1 Then
            ReDim tt(LBound(T, 1) To UBound(T, 1))

            For i = LBound(T, 1) To UBound(T, 1)
                tt(i) = T(i, 1)
            Next i

            '-------------------------------------------------
            'Tableau origine 2 dimensions dont la 2ème est > 1
            '=> Tableau destination 2 dimensions inversées
            '-------------------------------------------------
        Else
            ReDim tt(LBound(T, 2) To UBound(T, 2), LBound(T, 1) To UBound(T, 1))

            For i = LBound(T, 2) To UBound(T, 2)
                For j = LBound(T, 1) To UBound(T, 1)
                    tt(i, j) = T(j, i)
                Next j
            Next i
        End If
    End If

    TransposeExcel = tt
End Function

 Else
        'La fonction Dir() introduit des erreurs #52 ou #53 sur les objets Folder
        'de la boucle "For Each oSubDir In oDir.subfolders" ci-dessous.
        'IL NE FAUT PAS L'UTILISER !!!
        'SI SI IL FAUT L UTILISER !!!!!! :):):):)
        On Error Resume Next
        TakeIt = Len(Dir(oDir.Path & "\*." & Extension)) > 0
        If err.Number <> 0 Then TakeIt = True
        On Error GoTo 0
    End If

Sub testdirdegogole()
Item = Dir("h:\*.*") ' dir sur fichier uniquemement

Do While Item <> vbNullString


MsgBox Item

Item = Dir("e:\*.*") ' dir sur fichier uniquemement

Item = Dir 'on rapelle item soit le dirqui contient les argument de départ

Loop
End Sub

Sub a()
    Dim b As Boolean
    Dim i As Integer
    Dim TabRep() As Variant
    Dim Rep As String
 
    TabRep = Array("H:", "H:\Téléchargements", "H:\TEMP")
 
    For i = 1 To 3
        On Error Resume Next
        Rep = TabRep(i - 1) & "\*.txt"
        b = Len(Dir(Rep)) > 0
        MsgBox Rep & " = " & b & ", Err.Number = " & Err.Number
        On Error GoTo 0
    Next i
End Sub

Sub a()
    Call x(1)
End Sub

Sub x(ByVal NoAppel As Integer)
    Dim b As Boolean
    Dim i As Integer
    Static TabRep() As Variant
    Dim Rep As String
   
    If NoAppel = 1 Then
        TabRep = Array("H:", "H:\Téléchargements", "H:\TEMP")
    End If
   
    On Error Resume Next
    Rep = TabRep(NoAppel - 1) & "\*.txt"
    b = Len(Dir(Rep)) > 0
    MsgBox Rep & " = " & b & ", Err.Number = " & Err.Number
    On Error GoTo 0
   
    NoAppel = NoAppel + 1
    If NoAppel <= 3 Then Call x(NoAppel)
End Sub