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...

Dudu2

XLDnaute Barbatruc
Bonjour @patricktoulon, @ChTi160,

Pour simplifier encore dans cas, 1 seul On Error Resume Next en tête de fonction suffit.

Aussi, pour le temps, tu devrais sortir le chargement de la table à 2 dimensions qui n'a de sens que si le but est de valoriser un Range ce qui n'est pas forcément le cas d'un utilisateur de la fonction.

Mais je vois bien le problème d'initialiser la table ReDim T(0 to 0) sans avoir de candidat réel.
Je n'ai trouvé que 2 solutions pour ne pas avoir à gérer l'initialisation:
- soit utiliser une variable (ex. Nb as Long) et faire Nb = Nb + 1 : Redim Preserve T(1 to Nb) valable dans tous les cas (initialisation ou pas).
- soit tester If Not (Not T) then Redim Preserve T(1 to Ubound(T) + 1) Else Redim T(1 to 1)
J'utilise en général la 1ère solution.
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
j'ai bien essayé ceci mais on perds du temps
VB:
 On Error Resume Next
    For Each SubFolder In Lparent.subfolders
        x = Dir(Subfolder.Path & "\" & E) <> vbNullString
       If Err.Number = 0 Then If x Or subfolder.subfolders.Count > 0 Then recherche_récursive1 SubFolder.Path & "\", E, True, WithFolder
        Err.Clear:
    Next SubFolder
1° ici on gere l'erreur subfolder et dir avec on error resume next qui renvoie a la ligne suivante
don si for ech subfolder ....=erreur on passe à la ligne suivante le dir va faire erreur forcement et le subfolders.count aussi

2° tandis que si boucle ok mais pas dir l'erreur est gérée quand même puisque passe à la ligne suivante

3° si boucle ok mais pas dir mais il y a des subfolders dans le subfolder on part quand même

mais bon on gagne rien on ajoute au contraire
 

Dudu2

XLDnaute Barbatruc
Je ne suis pas sûr de comprendre ce que tu veux dire.

A partir du moment où tu as placé l'instruction On Error Resume Next dans la fonction, toute erreur sera interceptée, l'objet Err valorisé par Excel et l'instruction suivante exécutée. Et ça ne peut être arrêté que par un On Error GoTo 0.

Err.Clear ne fait qu'effacer l'objet Err mais ne change pas la gestion de l'exception due à une erreur.
Tu peux répéter l'instruction On Error Resume Next autant de fois que tu veux ça ne change rien.

De plus, ça me gène de lancer un On Error Resume Next sans "fermer le bloc erreur" par un On Error Goto 0. C'est comme ouvrir un parenthèse sans la fermer. Même si le Err.Clear viendra effacer l'objet Err et si "Sans On Error GoTo 0 instruction, un gestionnaire d’erreurs est automatiquement désactivé lorsqu’une procédure est quittée" comme le dit la doc MS.
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
non c'est pas ce que j'ai dis

on error resume next
for each ofiles in lparent.files
'supposons qu'il se passe une erreur ici
'err.clear' je bloque l'effacement de l'erreur elle va donc continuer a se promener
next

donc l'erreur boucle ofile n'est pas supprimée on est d'accords


'on error resume next 'donc ici on part direct en erreur puisqu'on l'est déjà par ofile
for ech subfolder in lparent.subfolder
if err.number =0 then
'ici le if n'est pas passé puisque erreur depuis ofile pourtant il y a peut etre des subfolder a visiter
end if
'err.clear
next

on ne peut donc pas associer un e gestion d'erreur pour les deux sinon ca va zapper des dossiers
on est donc bien obligé de gérer l'erreur ofile et l'effacer pour que dans la boucle subfolder ca soit sa propre erreur qui soit gérée
a moins d'utiliser le return de l'erreur
mais je pense que ça serait plus compliqué


ca donnerait un truc dans ce genre
on error resume next
for each.....

if err.number=0 or err.number<>70 then

'err.clear
end if
next

' mais ici je pense que l'erreur qui va suivre n'est pas traité il faudrait tester
'car le on error resume next n'est pas réamorcé (me semble t il)
for each sub....
if err.number=0 or err.number<>70 then

'err.clear
end if

next

--------------------

il faudrait tester
 

Dudu2

XLDnaute Barbatruc
'err.clear' je bloque l'effacement de l'erreur elle va donc continuer a se promener
Pourquoi veux-tu bloquer l'effacement de l'erreur ?
Bien sûr qu'il faut effacer l'erreur quand on l'a détectée pour pouvoir détecter la suivante.
If Err.Number = 0 Then 'Fait ce qu'il y a à faire Else Err.Clear

Mais ça n'a pas de rapport avec le On Error Resume Next.
Err.Clear ne "désamorce pas" la gestion de l'erreur.
 

ChTi160

XLDnaute Barbatruc
Bonsoir !
La gestion des erreurs un vaste sujet lol
Moi j'utilise le "On Error Résume Next"
J'applique systématiquement le "Err.clear"
Et aussi le On Error Toto 0 en fin de procédure
(Ce qui semble inutile) Lol
J'ai vu dans un des liens de Dudu que ce "On Error Goto 0" est mis en début de Procédure.
Pour ce qui est de l'explication de Patrick.
J'ai moi compris que dans l'imbrication de deux boucles si tu n'effaces pas l'erreur générée par la première si tu ne l'effaces pas lors du test "If Err.Number <> 0" dans la deuxième boucle le test prendra l'Err de la première boucle comme valeur et faussera la gestion d'erreur de la deuxième boucle. Lol
Bon ça c'est ce que moi j'ai compris.
Merci pour ces discussions qui me sont bénéfiques.
Bonne fin de soirée
Jean marie
 

patricktoulon

XLDnaute Barbatruc
ok je prends note
j'ai même testé en laissant juste le on error resume next du test ofile
ça tourne mais dans ma meilleure version je passe de 29.XXXXX à 38.XXXXXXX
autrement dit il y a quelque chose qui se compile à mon avis c'est les sessions gestion d'erreur elle même
qui sont compilée autant que d'appels récursif

alors j'essaie de mettre un error goto 0 (qui lui arrete la gestion dans!!! sa session de la fonction )après la boucle subfolder
et bien manque de pot je viens de tester ça s’arrête a 60 fichiers sur C

donc c'est pas cohérent avec la doc de MS

toujours est il qu'il y a bien charge en mémoire de ces erreurs
la question a 100 balles comment la décharger

ou!!!!!!!!
2d solution
il ne peut y avoir 2 gestion err.clear dans un bloc on error résume next

je précise que je teste avant de vous le dire donc c'est bien avéré
 
Dernière édition:

Dudu2

XLDnaute Barbatruc
VB:
Sub a()
    Dim i As Integer
    
    On Error Resume Next
    
    i = 10 / 0
    MsgBox "1 - Err.Number = " & Err.Number
    Err.Clear
    
    i = 32768
    MsgBox "2 - Err.Number = " & Err.Number
    Err.Clear
    
    On Error GoTo 0
End Sub
 

patricktoulon

XLDnaute Barbatruc
re je sais pas ce que tu veux demontrer mais dans la version la plus rapide

test comme ça
et test une 2d fois en déloquant la ligne on error resume next de la boucle subfolder
et en re bloquant celle du goto 0 à la fin de cette boucle

VB:
'**************************************************************
'fonction récursive pour lister les fichiers d'un disque ou dossier
'Utilisation de filesystemobject(FSO)
'auteur:  Dudu2 sur exceldownload
'Date:07/02/2021
'Modifiée  par patricktoulon le 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
'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))



'****************************************************************
Option Explicit
Option Compare Text

Sub TestListFichierFso()
    Dim Table As Variant, tim#: Const Répertoire = "c:\": tim = Timer
    ActiveSheet.Range("A1:A" & Rows.Count).ClearContents
    Table = FSO_List_FICHIERS(Répertoire, "*.txt")

    If IsArray(Table) Then
        Table = TransposeArray(Table)
        MsgBox UBound(Table) & " fichier(s) trouvé(s) dans le répertoire <" & Répertoire & "> en " & Timer - tim & " s/"
        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_FICHIERS(ByVal NomRépertoire As Variant, Optional PartName As String = "") As Variant
'Tableau résultat static pour être indépendant des appels récursifs
    Static TabNomsFichiers() As String: Static NbFichiers As Long: Static oFSO As Object

    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    'Valorise l'objet Folder
    Else                            'si Appel initial
        InitialCall = True
        Erase TabNomsFichiers    'Table résultat
        NbFichiers = 0
        Set oFSO = CreateObject("Scripting.FileSystemObject")    'File System Object
        If Right(NomRépertoire, 1) <> "\" Then NomRépertoire = NomRépertoire & "\"    'Complémente éventuellement le nom du répertoire avec '\'
        Set oDir = oFSO.GetFolder(NomRépertoire)    'Valorise l'objet Folder
    End If

    'Si op répertoire poubelle on ne traite pas\\\\
    'pour une liste complete :16 secondes perdues sur C avec 234000 ////4 secondes perdues sur h avec 4593 fichiers
    'If oDir.Name = "$RECYCLE.BIN" Or oDir.Name = "System Volume Information" Then Exit Function


    'Vérifie si le répertoire contient au moins un  fichier contenat  lePartName dans son nom
    'On Error Resume Next
    If Len(PartName) = 0 Then TakeIT = True Else TakeIT = True: TakeIT = Len(Dir(oDir.Path & "\" & PartName)) > 0
    If Err.Number <> 0 Then TakeIT = True: On Error GoTo 0

    'On n'examine les fichiers du répertoire que s'il contient des fichiers avec le PartName donc TakeIt =true
    If TakeIT Then
        On Error Resume Next
        For Each oFile In oDir.Files
            If Err.Number = 0 Then
                If Len(PartName) = 0 Then TakeIT = True Else If oFile.Name Like PartName Then TakeIT = True Else TakeIT = False
                If TakeIT Then NbFichiers = NbFichiers + 1: ReDim Preserve TabNomsFichiers(1 To NbFichiers): TabNomsFichiers(NbFichiers) = oFile.Path    'Stocke le nom complet du fichier en table
                Err.Clear    'Fichier en erreur ou examen du dossierinterdit
            End If
        Next oFile
    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
        Call FSO_List_FICHIERS(oSubDir, PartName)    'Appels recursifs identifiés par le type Object de l'argument OsubDir
        Err.Clear    'dossier en erreur ou examen du dossier interdit
    End If
    Next oSubDir
    On Error GoTo 0

    'Return value
    If InitialCall Then
        FSO_List_FICHIERS = False
        If NbFichiers > 0 Then FSO_List_FICHIERS = TabNomsFichiers
    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
 

Dudu2

XLDnaute Barbatruc
J'ai vu dans un des liens de Dudu que ce "On Error Goto 0" est mis en début de Procédure.
A mon avis ça ne sert à rien, car si la procédure appelante a défini un On Error, il va prévaloir sur le On Error Goto 0 de la procédure appelée.
Code:
Sub a()
    On Error Resume Next
    Call b
    MsgBox "Err.Number = " & Err.Number
End Sub

Sub b()
    Dim i As Integer
   
    On Error GoTo 0
    i = 10 / 0
End Sub
 

ChTi160

XLDnaute Barbatruc
Re
Patrick je crois
Que dans ta procédure #280
Tu n'as pas mis le Err.Clear au bon endroit
.
VB:
For Each oSubDir In oDir.subfolders
        If Err.Number = 0 Then
        Call FSO_List_FICHIERS(oSubDir, PartName)    'Appels recursifs identifiés par le type Object de l'argument OsubDir
        Err.Clear    'dossier en erreur ou examen du dossier interdit
    End If
    Next oSubDir
Il devrait être entre le End if et le Next
Ou alors pas compris lol
Jean marie
 

ChTi160

XLDnaute Barbatruc
Ben si err.Number N'est pas différent de 0
Il va sauter en dessous de End If est la on l'efface
Si pas d'erreur ça entre dans CALL
Je sais pas si je me fais comprendre lol
Mais le Err.Clear dans Err.Number= 0 ça sert à rien lol
Jean marie
 

Discussions similaires

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