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]

Bonjour,
Je te donne l'ossature pour accéder aux fichiers de tes sous-répertoires.
Il faut que tu complètes par le traitement que tu veux appliquer aux fichiers.

Option Explicit

Sub Test()
    Call FichiersSousRépertoires("H:\Téléchargements")
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 sous-répertoire       
        For Each oFile In oSubDir.Files
            Call TraiteFichier(oSubDir.Path, oFile.Name, oFile.Path)
        Next oFile
    Next oSubDir
End Sub

'-----------------------
'Traitement d'un fichier
'-----------------------
Sub TraiteFichier(NomRépertoire As String, NomFichier As String, NomCompletFichier As String)
    MsgBox "Traitement <" & NomRépertoire & "\" & NomFichier & ">"
End Sub

 

[hamzaelhathout]

Merci, pour ton aide.

J'ai testé et ça traite bien les fichiers mais je vois que ça traite tous les fichiers.

Est-il possible de prendre seulement les fichiers XXXX.txt ?

 

[Dudu2]

Je ne sais pas ce que tu entends par XXXX mais s'il s'agit de ne traiter que les fichiers Texte, dans le Sub TraiteFichier il suffit de tester son extension:

If Right(NomFichier, 4) = ".txt" then
<traitement du fichier>
End If

 

[hamzaelhathout]

En fait, il faut que le nom exact du fichier soit XXXX.txt, il y a d'autres fichiers texte dans les sous répertoires que je ne dois pas traiter.

 

[hamzaelhathout]

Super merci.

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

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 sous-répertoire
        For Each oFile In oSubDir.Files
            Call TraiteFichier(oSubDir.Path, oFile.Name, oFile.Path)
        Next oFile
    Next oSubDir
End Sub

'-----------------------
'Traitement d'un fichier
'-----------------------

Sub TraiteFichier(NomRépertoire As String, NomFichier As String, NomCompletFichier As String)
   If NomFichier = "XXXX.txt" Then
    MsgBox "Traitement <" & NomRépertoire & "\" & NomFichier & ">"
End If
End Sub

 

[Dudu2]

Voilà, c'est ça.
Maintenant dans le traitement il faut que tu fasses ce que tu as dit:

le copie avec comme nom, celui du sous dossier dans lequel il se trouve (donc aaaa-mm-jj.txt) vers un dossier "destination".

Ce que tu peux faire facilement puisque tu disposes du nom du sous-répertoire dans le paramètre NomRépertoire.

Pour copier un fichier, vous utiliserez l’instruction FileCopy :
FileCopy "source", "destination"
"source" et "destination" sont des noms complets (incluant le chemin et le nom du fichier).

 

[hamzaelhathout]

je peux donc utiliser ?

Filecopy NomCompletFichier, "C:\Users\...\destination\"" & " date()".txt"

Ca n'a pas trop l'aire d'être bon.

 

[hamzaelhathout]

Je me rend compte que c'est stupide. Ils auront tous le même nom si je met la date d'aujourd'hui.

Il faut que je trouve le moyen d'avoir le nom du sous dossier pour chaque fichier. Est-ce que tu peux m'aider pour créer une variable qui portera le nom du sous dossier ?

 

[hamzaelhathout]

En réalité ce serait plus quelque chose comme ça mais y a une erreur de syntaxe :

FileCopy NomCompletFichier, "C:\Users\...\destination\" & NomRépertoire & ".txt"

 

[Dudu2]

'-----------------------
'Traitement d'un fichier
'-----------------------

Sub TraiteFichier(NomRépertoire As String, NomFichier As String, NomCompletFichier As String)
    Const RépertoireDestination = "C:\Users\Youssef\Documents\fansub\testmacro\Destination\"
    If NomFichier = "XXXX.txt" Then
        FileCopy NomCompletFichier, RépertoireDestination & NomRépertoire & "-" & Format(Date, "yyyy-mm-dd") & ".txt"
    End If
End Sub

 

[Dudu2]

Oublié / corrigé le '\' sur Const RépertoireDestination .

 

[hamzaelhathout]

Il y a une erreur : Nom ou n0 de fichier incorrect,

c'est peut-être car le nom qu'il veut créer contient des /

Si c'est ça, Il faut réduire à 8 caractères de droite avec un right(NomRépertoire,8)

 

[patricktoulon]

bonsoir
juste en passant
a peu prés 10 fois plus rapide que scriptingfilesystem (ce gros lourdaud)

'patricktoulon
'basée sur ma fonction récursive avec dir de 2016
'tout les fichiers "XXXX.txt" seront trouvé et listés
Option Explicit
Sub testXy()
    Cells.Clear
    Dim liste As Variant, i&
    liste = listefichier("C:\Users\polux\DeskTop\dossier maitre\", partname:="XXXX", extention:=".txt")

    'maintenant  tu fait ce que tu veux avec la liste des fichiers trouvés
    ' exemple
    MsgBox Join(liste, vbCrLf)

    For i = LBound(liste) To UBound(liste)
        'te reste plus qu'a faire un filecopy ici dans la boucle
        '...

    Next

End Sub

Function listefichier(Dossier As String, Optional recall As Boolean = False, Optional tbl As Variant, Optional partname As String = "*", Optional extention As String = "*") As Variant
    Dim ItemVu As String, directory As Variant, SubFolderCollection As Collection, i As Long, A As Long, E As Long, subdossier
    Set SubFolderCollection = New Collection
    If recall = False Then ReDim tbl(0)    ' si recall  on redim un tableau  de zero item (pour la creation du tableau)
    On Error Resume Next    'gestion des fichiers dossiers system et interdit ou generant une erreur(PerLog,recycle,etc..)
    ItemVu = Dir(Dossier, vbDirectory)
    If Error.Number = 0 Then    ' si pas d'erreur on examine le contenu
        'examen  du dossier courrant
        Do Until ItemVu = vbNullString
            If Left(ItemVu, 1) <> "." Then
                If (GetAttr(Dossier & ItemVu) And vbDirectory) = vbDirectory Then
                    SubFolderCollection.Add ItemVu
                Else
                    If Left(ItemVu, Len(partname)) = partname And Right(ItemVu, 4) = extention Then A = UBound(tbl) + 1: ReDim Preserve tbl(1 To A): tbl(A) = Dossier & ItemVu

                End If
            End If
            ItemVu = Dir()
        Loop
    Else
        Err.Clear
    End If
    'examen des sub dossier
    For Each subdossier In SubFolderCollection
        'A = UBound(tbl) + 1: ReDim Preserve tbl(1 To A): tbl(A) = Dossier & subdossier' si on veut lister les dossiers aussi
        listefichier Dossier & subdossier & "\", True, tbl, partname, extention
    Next subdossier
    listefichier = tbl
End Function

 

[hamzaelhathout]

Merci à toi, le seul problème qui me reste est justement le Filecopy

Je voudrais copier le fichier texte dans un dossier cible en le renommant du même nom que celui du dossier dans lequel il se trouvait.