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
Pour la longueur Max je trouve plusieurs valeurs: 260, 255. Je pense que ça concerne un chemin complet fichier. Alors que dans notre code on est sur un Dir(chemin complet répertoire).
J'ai récupéré une erreur #53 avec un oDir.Path de 254 caractères.

J'ai essayé via l'Explorateur Windows et le plus grand chemin répertoire que j'arrive à définir fait 247 caractères.
Sous ce répertoire j'ai pu créer un fichier de nom 11 caractères.
Ce qui chemin répertoire (247) + "\" + nom fichier (11) donne 259
caractères de limite pour un chemin complet de fichier.

Sur cette base je dirais que la limite pour un chemin répertoire est de 247 caractères.
Sur cette base je dirais que la limite pour un chemin fichier est de 259 caractères.


L'idée que tu suggères dans ton lien (Est-il un moyen pour DIR(chemin) en VBA pour gérer les chaînes de plus de 260?) de se placer (ChDir) dans le répertoire immédiatement supérieur de longueur de chemin complet < Max et de référencer ce chemin par ".\" est sans doute à regarder car le chemin passé au Dir() sera plus évidemment court. Et d'après ce lien, le Dir() devrait fonctionner sans erreur #53.

La question est de savoir si ça vaut le coup de se lancer dans un code plus complexe juste pour récupérer ces erreurs #53 sur Dir() qui est juste une pré-sélection de répertoire pour présence de l'extension. Si il y a erreur on l'ignore.

Par contre, je pense qu'il vaut mieux se focaliser sur les erreurs #76 similaires aux erreurs #53 qu'on a sur les objets FSO apparemment sur des répertoires dont le chemin complet > 257 caractères. Ça c'est l'objet des prochaines investigations sur ce sujet sans fin
 
Dernière édition:

Dudu2

XLDnaute Barbatruc
Intéressant ! Je suis en Windows 7 donc limité.
J'ai corrigé mon Post #256.

Ce qui est étonnant c'est que j'ai pu créer sur mon disque (en copiant des répertoires de CD par exemple) des répertoires dont le chemin complet est > 247 et des fichiers dont le chemin complet est > 259.

De plus un logiciel comme FreeFileSync est capable de synchroniser ces répertoires et fichiers aux longueurs extravagantes.
 

Dudu2

XLDnaute Barbatruc
Si on peut (je n'ai pas testé) trouver un biais avec Dir() en utilisant ChDir et ".\" pour éliminer le problème de la longueur max, on ne peut pas le faire avec les objets FSO qui travaillent sur les chemins complets.

Donc je ne vois pas de solution pour l'erreur #76 en FSO. Il faut accepter de ne pas récupérer les fichiers qui sont sous des répertoires à rallonge (sauf Window 10 et modif registre comme l'a signalé @ChTi160).

La méthode DIR VBA serait sans doute adaptable mais n'est pas compatible avec les noms de répertoires ou fichiers contenant des caractères Unicode.

Entre 2 maux il faut choisir le moindre et mon choix perso va plutôt vers FSO.
 

patricktoulon

XLDnaute Barbatruc
re
bonjour @Dudu2 , @Cht160
j'annonce la couleur
avec FSO j'ai battu DIR vba en éliminant les gestions d'erreurs inutiles en éliminant le test recycle et l'autre avec étonnement le shunt RECYCLE est la plus grande perte de temps dans le code
une autre chose bizarre ;on error goto 0 est plus lourd que err.clear ???????????
2 gestion d'erreur chacune pour les deux boucles c'est inutile puisque on error resume next passe a la ligne suivante donc on garde celle dans la boucle et on vire celle en extérieur


je bat DIR car je ne peux pas faire un dir (dossier &"\" & ext)pour shunter les dossier n'en contenant pas
j’essaierais avec une fonction externe

résultat je passe en dessous la barre ou tout juste des 30 secondes pour C avec 234000 fichiers et 4602 fichiers ".text" trouvés
avec DIR je suis à 33
aucun plantage
 

patricktoulon

XLDnaute Barbatruc
oui t'inquiet
re
VB:
Option Compare Text
Sub testFSO()
    [A1].CurrentRegion.ClearContents
    Dim Racine$, tim, Ext$, T
    Racine = "h:\"    ' disque à lister
    tim = Timer
    Ext = "*.txt"    ' une partie du nom  et l'extension
    'T = recherche_récursive1(Racine)                             'tout les fichiers
    'T = recherche_récursive1(Racine, withdolder:=True)           ' atout les fichiers et leur dossier parent
    T = recherche_récursive1(Racine, Ext)                        ' avec extention "*.txt"
    'T = recherche_récursive1(Racine, Ext, withdolder:=True)      ' avec extention "*.txt" et leur dossier parent
    MsgBox (Timer - tim) & " secondes ; " & UBound(T) & " fichiers avec FSO"
    If UBound(T) > 0 Then Cells(1, 1).Resize(UBound(T), 1) = T
End Sub
'
'
Private Function recherche_récursive1(dparent As String, Optional E As String = "", Optional recall As Boolean = False, Optional WithFolder As Boolean = False)   ' As Variant
    Static FSO As Object: Static T$(): Dim Lparent As Object, SubFolder As Object, Ficher, TakeIT As Variant, x

    If Not recall Then ReDim T(0): Set FSO = CreateObject("scripting.filesystemobject")    ' on declare l'object
    Set Lparent = FSO.GetFolder(dparent)

    'If Lparent.Name = "$RECYCLE.BIN" Or Lparent.Name = "System Volume Information" Then Exit Function
    '4 secondes environ supplementaires sur le disque H en entiere et plus selon le nombre de fichiers dans la poubelle
    TakeIT = True
    If E <> "" Then
        On Error Resume Next
        TakeIT = Dir(Lparent.Path & "\" & E) <> vbNullString
        If Err.Number > 0 Then Err.Clear: TakeIT = False
    End If

    If TakeIT Then
        If WithFolder Then ReDim Preserve T(UBound(T) + 1): T(UBound(T) - 1) = Lparent.Path
        On Error Resume Next
        For Each Ficher In Lparent.Files
            If Err.Number = 0 Then
                If E <> "" Then
                    If Ficher.Name Like E Then ReDim Preserve T(UBound(T) + 1): T(UBound(T) - 1) = Ficher:
                Else
                    ReDim Preserve T(UBound(T) + 1): T(UBound(T) - 1) = Ficher:
                End If
            End If
            Err.Clear
        Next
    End If

    On Error Resume Next
    For Each SubFolder In Lparent.subfolders
        If Err.Number = 0 Then recherche_récursive1 SubFolder.Path & "\", E, True, WithFolder
        Err.Clear:
    Next SubFolder

    If Not recall Then
        ReDim tbl(UBound(T), 1 To 1)
        For I = LBound(T) To UBound(T): tbl(I, 1) = T(I): Next
        recherche_récursive1 = tbl
    End If
End Function
 
Dernière édition:

Discussions similaires

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