Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

hamzaelhathout

XLDnaute Nouveau
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.
 
Solution
Super merci.

J'ai adapté pour le nom du fichier exact.

VB:
Option Explicit

Sub Test()
    Call FichiersSousRépertoires("C:\Users\Youssef\Documents\fansub\testmacro\")
End Sub

'---------------------------------------------
'Fichiers des sous-répertoires d'un répertoire
'---------------------------------------------
Sub FichiersSousRépertoires(NomRépertoire As String)
    Dim oFSO As Object
    Dim oDir As Object
    Dim oSubDir As Object
    Dim oFile As Object

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

    'Directory Object
    Set oDir = oFSO.GetFolder(NomRépertoire)

    'Parcours des sous-répertoires du répertoire
    For Each oSubDir In oDir.SubFolders
        'Parcours des fichiers du...

patricktoulon

XLDnaute Barbatruc
bon j'ai fait tout les test
test1-------------------------------------------
on error resume next
boucle ofile + err.clear

on error resume next
bouclesubfolder+err.clear
29.04XXXX
-------------------------------------------------
test2
on error resume next
boucle ofile + err.clear

on error resume next
bouclesubfolder+err.clear
on error goto 0
33 secondes
---------------------------------------------------
test3
on error resume next
boucle ofile + err.clear


bouclesubfolder+err.clear
on error goto 0
38.XXXXXXXXsecondes
----------------------------------------------------

et je l'ai fait 5 ou 6 fois pour les 3 en réinitialisant VBE à chaque fois pour qu'il n'y ai pas de charge mémoire au depart
 

ChTi160

XLDnaute Barbatruc
Re crois que dans les test 1 et 2
Tu n'as besoin que d'un on Error Résume Next
Le On Error Goto 0 n'apporte rien au niveau du temps de réalisation puisqu'il remet la gestion a zéro.
Chose qui se réalise en sortie de procédure.
Merci a vous !
Bonne fin de Soirée
Jean marie
 

patricktoulon

XLDnaute Barbatruc
le problème avec ça, c'est que on error goto 0 comme l'a fait au départ @Dudu2 soit 2 bloc consomme entre 15 et 20 secondes supplémentaires sur C
pourtant on pourrait croire que décharger allégerait la chose mais non

le problème de la mono gestion c'est qu'elle est déchargée quand la récursivité revient a sa session
si beaucoup de sous sous dossier ben c'est pas gagné

et enfin le plus surprenant sans décharge de la gestion je vais plus vite

va savoir????
 

Dudu2

XLDnaute Barbatruc
c'est que on error goto 0 comme l'a fait au départ @Dudu2 soit 2 bloc consomme entre 15 et 20 secondes supplémentaires sur C
Ça c'est normal, on appelle des fonctions système qui mettent en place ou suppriment la gestion d'erreur et ça prend du temps.

Je fais ça pour limiter le scope de l'interception d'erreur au cas où d'autres erreurs non reliées à ce qu'on veut intercepter arrivent.

D'ailleurs dans cet objectif d'être sûr de capter l'erreur ciblée et seulement elle, au lieu de faire ça:
VB:
    On Error Resume Next
    For Each oFile In oDir.Files
        'Traitement
    Next i
    On Error GoTo 0

j'aurais voulu faire ça (quitte à allonger le traitement):
Code:
    For i = 1 To oDir.Files.Count
        On Error Resume Next
        Set oFile = oDir.Files(i)
        On Error GoTo 0
     
        'Traitement
    Next i
Mais hélas oDir.Files(i) ne fonctionne pas.
 

patricktoulon

XLDnaute Barbatruc
re
et oui j'ai essayé hier ça justement pour déclencher et virer l'erreur tout de suite mais ça marche pas en effet

donc conclusion pour l’enquête d'aujourd'hui c'est pas dans la gestion error que je vais gagner des confettis

demain j’enquêterais sur une double boucle do loop imbriqué et récursive
a l’intérieur de la fonction récursive
tu me dira de 233 on est a 29 S c'est déjà pas mal mais je suis convaincu que je peux faire mieux encore
 

Dudu2

XLDnaute Barbatruc
C'est quoi ta moto ?
Moi j'ai revendu ma RT1200 pour un scooter 300 cm3 pour les déplacements en ville. Mais j'ai envie de me reprendre une petite VSTROM 650 histoire de rouler tranquille sur les routes du Var et des AM au printemps et en été.
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
bonjour a tout les deux
@Dudu2
cbr 900 mais je compte prendre un trail moi aussi par rapport a mon dos mais je sais pas quoi j'avoue que j'ai du mal a me voir la dessus

aujourd'hui mon enquête et mes recherche porteront sur un do loop imbriquées
en visio un pot au canada avec moins de puissance que moi a descendu a 15 secondes sur C
on doit pouvoir j'ai pas voulu qu'il me donne son code je veux découvrir tout seul
 

patricktoulon

XLDnaute Barbatruc
re
j'ai repris un code simple de base
je n'arrive pas a descendre en dessous de 0.84XX pour le disk h avec 22 fichiers txt pour 4604 fichier au total
le do loop je sait pas comment mon pot a fait sachant que l'on boucle sur 2 object différents(dossiers/fichiers)
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
re
bonjour tout les deux

bon alors conclusion
1° pour une recherche ciblée il est peut être préférable d'utiliser FSO
2° pour une liste compléte du disque ou dossier préférer utiliser dir vba


pour quoi la recherche ciblée est plus rapide avec FSO alors qu'il faut détailler:
et bien tout simplement parce que que l'on peut zapper des listages sur certains dossiers si le test dir n'est pas concluant
tandis qu'avec dir vba qui boucle sur dir vbdirectory(dossier/fichier) il n'y a pas moyen d'intercepter (si il y a des fichier avec ext ou pas )

3°revenons à TakeIt dans le modele de base de @Dudu2
TakeIt est déterminé plusieurs fois mais on peut en faire sauter un en jumpant après le dir négatif avec un go sub
ce qui nous fait gagner quelque centièmes et/ou plusieurs secondes selon l'importance du nombre de dossier/fichiers sur le disque
on passe ainsi directement a scanFolder sans passer par le le if Takit pour ofile

4°pour la partie gestion d'erreur j’arrête ma décision sur une gestion globale arrêtée a chaque fin de session
le temps gagné par une gestion ofile/subfolder est perdu rien qu'avec l’exécution des ligne elle même " if.." répétée

5°la partie if string ou object nous fait effectivement gagner quelque confettis(c'est toujours bon a prendre )

6°de plus plus il y a de fichiers a prendre plus le temps augmente d'une part par le nombre d'appels mais aussi la charge mémoire du tableau consomme aussi



donc ma définitive FSO pour recherche ciblée au vues de tous ces tests sera

essayez la vous me direz
VB:
'**************************************************************
'fonction récursive pour lister les fichiers d'un disque ou dossier
'Utilisation de filesystemobject(FSO)
'sur la base de la version de Dudu2 sur exceldownload
'Modifiée  par patricktoulon
''version 1.5
'Date:08/02/2021
'mise en place du principe (Part name) valable aussi pour (si juste extension demandée:ex;[*.XXX])
'suppression du stockage des erreurs et des msgbox d'erreur
'suppression commentaires
'utilisation d'une fonction de transposition de l'array simplifiée (horizontal(1 dim) To vertical(2 dim))

'Date:08/02/2021
'accélération du processus
'en ajoutant du test dir non bloquant pour zapper les dossiers
'ne contenant pas de fichier avec l'extension ou la partie du nom demandée
'Date:13/02/2021
'remplacement du test if takeit par un jumping (etiquette "ScanFolder")
'pour jumper directement sur la boucle des dossiers on  zappe directement la partie du code boucle ofile
'****************************************************************
Option Explicit
Option Compare Text
Dim Appelcount
Dim countdoss
'
Sub listeFSO0x()
    Dim Table As Variant, tim
    ActiveSheet.Range("A1:A" & Rows.Count).ClearContents
    Const Répertoire = "c:\": tim = Timer
    Const Ext$ = "*.txt"
    Appelcount = 0    '
    countdoss = 0
    Table = FSO_List_FICHIERS2(Répertoire, Ext)
    If IsArray(Table) Then
        Table = TransposeArray(Table)
        tim = Format(Timer - tim, "#0.000 S")

        MsgBox UBound(Table) & " fichier(s)<""" & Ext & """> trouvé(s) dans le répertoire <" & Répertoire & "> en " & tim & " s/" & _
               vbCrLf & "pour " & Appelcount & " appels de la fonction sur dossier   et  " & countdoss & " dossiers seulement en contiennent "

        ActiveSheet.Range("A1").Resize(UBound(Table)).Value = Table

    Else
        MsgBox "Aucun fichier dans le répertoire <" & Répertoire & ">"
    End If
End Sub

Function FSO_List_FICHIERS2(ByVal NomRépertoire As Variant, Optional PartName As String = "") As Variant
    Static tbl() As String: Static NbFichiers As Long: Static oFSO As Object
    Appelcount = Appelcount + 1
    countdoss = countdoss + 1
    Dim oDir As Object, oSubDir As Object, oFile As Object, InitialCall As Boolean, TakeIT As Boolean
    If TypeOf NomRépertoire Is Object  Then
        InitialCall = False
        Set oDir = NomRépertoire
    Else
        InitialCall = True
        Erase tbl
        NbFichiers = 0
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        If Right(NomRépertoire, 1) <> "\" Then NomRépertoire = NomRépertoire & "\"
        Set oDir = oFSO.getfolder(NomRépertoire)
    End If


    TakeIT = True
    On Error Resume Next
    TakeIT = Len(Dir(oDir.Path & "\" & PartName)) > 0
    If Err.Number <> 0 Or TakeIT = False Then Err.Clear: countdoss = countdoss - 1: GoSub Scanfolder

    For Each oFile In oDir.Files
        If Err.Number = 0 Then
            If Len(PartName) = 0 Then
                NbFichiers = NbFichiers + 1: ReDim Preserve tbl(1 To NbFichiers): tbl(NbFichiers) = oFile.Path
            Else
                If oFile.Name Like PartName Then NbFichiers = NbFichiers + 1: ReDim Preserve tbl(1 To NbFichiers): tbl(NbFichiers) = oFile.Path                'Stocke le nom complet du fichier en table
            End If
        End If
        Err.Clear
    Next oFile
    On Error GoTo 0

Scanfolder:

    For Each oSubDir In oDir.subfolders
         If Err.Number = 0 Then
          FSO_List_FICHIERS2 oSubDir, PartName
        Else: Err.Clear
        End If
    Next oSubDir

    On Error GoTo 0

    If InitialCall Then
        FSO_List_FICHIERS2 = False
        If NbFichiers > 0 Then FSO_List_FICHIERS2 = tbl
    End If

End Function
Function TransposeArray(arr)
    Dim tbl(), I&: ReDim tbl(LBound(arr) To UBound(arr), 1 To 1)
    For I = LBound(arr) To UBound(arr): tbl(I, 1) = arr(I): Next
    TransposeArray = tbl
End Function
et @Dudu2 qui gagne le ponpon
 

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…