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.

 

[kiki29]

Re, pour les temps voir ici , pour APIs voir là, sans doute adaptable

 

[patricktoulon]

re
bonsoir @kiki29
avec les api pour le même disque 0.480 s pour 4593 fichiers
les deux fonctions dir sont a peine un plus rapides pas de beaucoup 0.3XXXXX

et elle trouvent aussi 4593 fichiers
et encore elle sont ralenties par la boucle de replacement des caractères spéciaux qui posent problème avec getattr

version @patricktoulon

la version de @Dudu2

ta version avec les apis

pour une fois les apis sont battues

 

[kiki29]

Re, trop peu de fichiers pour être significatif. Pourquoi ne pas tester avec 1 fichier ?

 

[Dudu2]

Code Review...

Quelle nouille ! Je me suis fait avoir avec la récursivité en ne protégeant pas la valorisation du retour de la fonction par la vérification qu'il s'agit bien de l'appel initial

.

Bon j'ai corrigé le fichier du post #72 et ça rend les fonctions 10% plus rapides.

Et d'après ton dernier code listé, je pense que toi aussi

tu peux économiser sur le DirList = tbl quand ce n'est pas nécessaire.

Et aussi...

et encore elle sont ralenties par la boucle de replacement des caractères spéciaux qui posent problème avec getattr

Tu ne devrais le faire que lorsqu'une erreur a été détectée dans le GetAttr() sinon c'est inutile.

Enfin méfie-toi du If Left(ItemVu, 1) <> "." Then car le nom d'un fichier peut très bien commencer par '.'.

En gros, sur 6000 fichiers, sur mon PC:
Méthode Dir = 0.20 sec
Méthode FSO = 1.10 sec
Soit un rapport de 1 à 5.5 ce qui moins important qu'attendu.
De plus la méthode FSO est plus sécurisante car comment savoir si la bidouille de rattrapage des accents sur la méthode Dir couvre tous les cas ?

 

[patricktoulon]

re
perso la mienne l'apel initial est bien détermine (l'argument recall)
si recall tbl redimé sinon non

pour la fin "fonction=tbl "je sais pas si ça changerait quelque chose
j'ai pensé aussi la modifier comme ma version FSO a savoir: injecter un tableau vide
on aurait plus de soucis
pour les accents bien sur l'experience nous fera rajouter des trucs avec le temps je m'en doute

bon ta new version testée on tombe à moins 0.2

 

[patricktoulon]

bon
j'ai appliquer la boucle replace uniquement sur les erreur fichier(caractères spéciaux) ne passant pas dans la gestion d'erreur directory

j'ai aussi comme je l'avais dis hier passer ma variable tableau(tbl) en static elle n'est donc plus baladée dans la récursivité et comme je le pensais c'est bien la raison que @Dudu2 était plus rapide que moi
résultat des courses on a le même temps en dessous de 0.2 pour 4593 fichiers
purée les api loin loin derrière

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

purée ça dépote
et désolé @Dudu2 là c'est moi qui gagne

je sais pas pourquoi tu a mis un msgbox d'erreur dans ta new version mais bon l'ancienne était plus rapide là tu est remonté à 0.4XXXXXX pour 4592 fichier celui en erreur n’étant pas traité et shunté
et pour la FSO c'est moi qui gagne aussi je suis en dessous de 1

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

en tout cas chez moi

 

[Dudu2]

Ola @patricktoulon,
Bien joué ! A mon avis ce qui te fait gagner c'est surtout cette boucle seulement sur les erreurs.
Je ne suis pas sûr que de passer la table en Static t'a fait tellement gagner par rapport au fait de la trimballer en argument sur les Call récursifs à partir du moment, bien sûr, où cet argument est ByRef car il n'y a pas de réallocation/copie mémoire de la table et c'est juste son adresse qui est passée à chaque fois.

 

[Dudu2]

Et je suis persuadé que tu gagnerais encore en réservant ton If SubFolderCollection.Count > 0 Then DirList = tbl au seul appel initial. Car là il y a bien de l'allocation et de la copie mémoire.

 

[patricktoulon]

re
bonjour @Dudu2
ah si!!
avec la gestion replacement caractères seulement au moment du besoins je suis passé de 0.6XXXXX à 0.3XXXXX

et avec tbl Static je suis passé de 0.3XXXX à 0.1XXXXXX

et ta version la plus rapide est celle ci

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

 

[patricktoulon]

Et je suis persuadé que tu gagnerais encore en réservant ton If SubFolderCollection.Count > 0 Then DirList = tbl au seul appel initial. Car là il y a bien de l'allocation et de la copie mémoire.

???????????
je sais pas si les appels 2,3,etc... ferait que ltbl étant alloué serait rempli dans la récursivité
à tester

purée incroyable quand je pense qu'avec 2/3 secondes j'étais content

 

[Dudu2]

je sais pas si les appels 2,3,etc... ferait que ltbl étant alloué serait rempli dans la récursivité
à tester

Les appels 2, 3, etc.. n'utilisent jamais le résultat de la fonction.
'examen des sub dossier appel récursif
For Each subdossier In SubFolderCollection
DirList subdossier & "\", True
Next subdossier
Dans cette instruction en rouge tu appelles la fonction mais n'en utilise jamais la valeur de retour.
C'est comme un Call DirList(subdossier & "\", True) donc ça ne sert à rien de la valoriser.

 

[patricktoulon]

re
Ah!!!...
testé ben j'aurais appris quelque chose
je gagne encore 0.02 je passe en dessous les 0.15

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

donc avec un static alimenté en récursif la fonction allouant le return la première fois en mémoire est mis a jour dans la récursivité (j'aurais pas cru )
waouahww!!

pétant!! ca depote 0.15 pour dir 0.875 pour FSO avec mes versions

 

[patricktoulon]

là je crois que l'on peu pas faire mieux

 

[Dudu2]

"La perfection n'est pas de ce monde" disent certains.
Désolé, nous l'avons atteinte. En toute modestie bien sûr.

 

[patricktoulon]

re
encore faut il s'appeler @Dudu2 ou @patricktoulon

purée pour le disk C(disques d'exploition

contre 4.5 minutes avant avec dir