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.

 

[Dudu2]

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

 

[patricktoulon]

re
bonsoir
ma dir vba les récupère les chemin erreur 53 la fso aussi d'ailleurs
les gestions d'erreurs sont là pour ça non?

 

[ChTi160]

Re
Merci les Gars !
jean marie

 

[Dudu2]

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.

 

[patricktoulon]

RE
avec MA fonction dir vba et un dossier avec un nombre de 290 caractères pour le nom +un sous dossier+un fichier dont nom contient 196 caractères

aucun problème

Avec le FSO 1 DE DUDU2

 

[patricktoulon]

re
effectivement les outils vba mkdir et compagnie limite a 251 chez moi mais pour le chemin complet
donc en lecture c'est bon mais en création non

 

[Dudu2]

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]

@Dudu2 tu veux la compil?

 

[ChTi160]

Moi Oui ! mdr
merci

 

[Dudu2]

Envoie mon @patricktoulon

 

[patricktoulon]

re:
les 4 que je retiens pour l'instant

 

[ChTi160]

Merci Patrick !
jean marie

 

[patricktoulon]

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

 

[ChTi160]

Bonjour Patrick
Bonjour le Fil
Je vois que tu ne lâches rien lol
Tu vas joindre la dernière version?
Que je teste lol
Bonne journée
Jean marie

 

[patricktoulon]

oui t'inquiet
re

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