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

[hamzaelhathout]

Bonjour,

J'ai un dossier qui contiens plusieurs sous-dossier pour chaque journée qui ont pour nom "aaaa-mm-jj".
Dans ces sous-dossier, il y a un rapport au format txt qui a toujours le même nom "XXXXX.txt"

Je voudrais créer une macro qui aille chercher ce fichier txt dans chaque sous dossier et me le copie avec comme nom, celui du sous dossier dans lequel il se trouve (donc aaaa-mm-jj.txt) vers un dossier "destination".

J'ai cherché dans le forum mais je n'ai pas trouvé exactement ça.

Merci d'avance.

 

[patricktoulon]

avec la tienne avec le replace

je te la redonne

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

 

[patricktoulon]

@Dudu2 tu en es ou?

 

[Dudu2]

J'en suis que j'applique ta méthode de correction. Voilà
Avec juste tous les caractères à accent séparable que j'ai pu trouver sur mon clavier:

    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

 

[patricktoulon]

oui ma fois
comme je te l'ai dis l'utilisation ne manquera pas de nous rappeler un manquant
des que tu a fini au propre tu me la donne je stock
la mienne

 

[patricktoulon]

re
ok je regarde ça toute a l'heure

 

[patricktoulon]

ok testé
0.5XXXXXX secondes pour les deux méthodes sur le disque complet 4593 fichiers


par contre le test null plante chez moi alors

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

Alors tu préfère toujours FSO

 

[Dudu2]

@patricktoulon, j'ai foiré sur le retour vide.
J'ai donc modifié le code ci-dessus à reprendre.
Attends, je vais regarder ta solution IsArray()
Bon c'est équivalent à tester le VarType du retour à Boolean, ça marche dans les 2 cas.
Donc reprends le code pour la fin qui met à le retour à False.

 

[patricktoulon]

ben j'ai corrigé avant voir post précédent
par contre j'ai pas encore compris pour quoi puisque avant return tu met

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

 

[patricktoulon]

re
ok boolean ça marche aussi

 

[patricktoulon]

ca y est dudu a disjonté

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

 

[patricktoulon]

re
on passe de 0.3 à0.5 en dir à 1.1 à 1.5 en fso

c'est quand meme pas mal

 

[Dudu2]

C'est là finalement qu'il faut les prendre.
Méthode VBA DIR
Méthode DOS DIR
Méthode VBA FSO


Edit: fichier modifié 10/02/2021 19h55

 

[patricktoulon]

ho t'inquiet j'ai corrigé testé plusieurs fois déjà

c'est pas mal du tout pour du FSO
je compile demain là la tete en vrac à fonctionner avec deux logique(la tienne et la mienne) j'ai la tete en sky et les cheveux pousse a l’intérieur

 

[Dudu2]

ok bonne nuit

 

[patricktoulon]

re
puré je suis testard
a ma grande surprise
ta fonction dir est plus rapide que la mienne de quelle milimilimilimili
par contre ma fonction fso est largement plus rapide , je suis en dessous les 0.9
moi qui cris haut et fort que dir c'est mieux ça la fout mal hein

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

mais bon dans l'ensemble on a 4 fonctions 2 dir /2 FSO qui sont assez rapides
dir est quand meme plus rapide

ta fonction dir est plus rapide car tu utilise des variables statiques alors que moi je les ballades entre les tours récursifs pour les garder chargées