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

hamzaelhathout · 3 Février 2021

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.

hamzaelhathout · 3 Février 2021

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 · 4 Février 2021

essaie juste le meme sans les espaces

patricktoulon · 4 Février 2021

tiens en dos dans mes archives

Enrichi (BBcode):

Sub CmdDos()
    Dim laChaine As String, x
    ' Exécute la commande DOS dir
   Shell "C:\Windows\System32\cmd.exe /C dir h:\*.* /s/b >h:\list.txt", vbHide
    x = FreeFile: Open "h:\list.txt" For Binary Access Read As #x: laChaine = String(LOF(x), " "): Get #x, , laChaine:    Close #x
    tbl = Split(laChaine, vbCrLf)
[A1].Resize(UBound(tbl), 1) = Application.Transpose(tbl)
kill "h:\list.txt"
End Sub

c'est encore plus rapide mais on le choppe toujours pas

Dudu2 · 4 Février 2021

En fait c'est pas le Dir(). Un simple copy en F2 et paste donne le même résultat d'accents décalés.
Je ne sais pas pourquoi Windows Explorer le représente différemment avec les accents sur les lettres.
Donc les Replace ne changent rien, le fichier reste en erreur pour le GetAttr() avec les accents décalés ou pas.

patricktoulon · 4 Février 2021

?????????

Dudu2 · 4 Février 2021

En fait:
- quand je copie le nom du fichier dans un fichier Texte -> ça passe
- quand je copie le nom du fichier dans l'éditeur VBA -> ça ne passe pas !

Dudu2 · 4 Février 2021

J'ai enfin réussi à faire "ma" version d'une liste avec Dir(). Juste pour essayer.
Le nom traficoté par VBA est présent, même si ce n'est pas le vrai nom du fichier.

VB:

Option Explicit

Sub TestFichiersRépertoireDIR()
    Const Répertoire = "H:" ' "H:\Téléchargements"
    Call FichiersRépertoireDIR(Répertoire)
End Sub

'-------------------------------------------------------------
'Liste des fichiers de l'arborescence complète d'un répertoire
'-------------------------------------------------------------
Function FichiersRépertoireDIR(ByVal NomRépertoire As String, Optional NoRecycle As Boolean = True) As Variant
    Static TabNomsFichiers() As String
    Static NbFichiers As Long
    Dim TabSubFolders() As String
    Dim NbSubFolders As Long
    Dim NomItem As String
    Dim i As Long
    Dim Bool As Boolean
    Dim ErrNumber As Variant
    
    'Appel recursif de cette fonction
    If Left(NomRépertoire, 1) = "|" Then
        NomRépertoire = Mid(NomRépertoire, 2)        
    'Appel initial
    Else
        Erase TabNomsFichiers
        NbFichiers = 0
    End If
    
    If Right(NomRépertoire, 1) <> "\" Then NomRépertoire = NomRépertoire & "\"
    
    '1er item dans le répertoire
    On Error Resume Next
    NomItem = Dir(NomRépertoire, vbDirectory Or vbSystem Or vbHidden)
    ErrNumber = err.Number
    On Error GoTo 0
    If ErrNumber <> 0 Then Exit Function
    
    Do While Len(NomItem) > 0
        'L'item est un répertoire
        On Error Resume Next
        Bool = False
        Bool = (GetAttr(NomRépertoire & NomItem) And vbDirectory) = vbDirectory
        ErrNumber = err.Number
        On Error GoTo 0
        
        'L'item est un répertoire
        If Bool Then
            If NomItem = "." Or NomItem = ".." _
            Or NomItem = "System Volume Information" _
            Or (NoRecycle And NomItem = "$RECYCLE.BIN") Then
            Else
                NbSubFolders = NbSubFolders + 1
                ReDim Preserve TabSubFolders(1 To NbSubFolders)
                TabSubFolders(NbSubFolders) = NomItem
            End If
        
        'L'item est un fichier
        Else
            NbFichiers = NbFichiers + 1
            ReDim Preserve TabNomsFichiers(1 To NbFichiers)
            TabNomsFichiers(NbFichiers) = NomRépertoire & NomItem
        End If
        
        'Item suivant dans le répertoire
        NomItem = Dir()
    Loop
    
    For i = 1 To NbSubFolders
        'Appels recursifs idntifiés par "|" en début du nom de répertoire
        Call FichiersRépertoireDIR("|" & NomRépertoire & TabSubFolders(i), NoRecycle:=NoRecycle)
    Next i
    
    'Return value
    FichiersRépertoireDIR = TabNomsFichiers
End Function

patricktoulon · 4 Février 2021

re
je teste pas je te fait confiance
mais ici tu fait une erreur monumentale

VB:

 '1er item dans le répertoire
    On Error Resume Next
    NomItem = Dir(NomRépertoire, vbDirectory Or vbSystem Or vbHidden)
    ErrNumber = err.Number
    On Error GoTo 0
    If ErrNumber <> 0 Then Exit Function

si une erreur se produit tu arrete le listage
je vais essayer d'intégrer ton cbool dans la mienne

patricktoulon · 4 Février 2021

ok autant pour moi mille excuse on le choppe
par contre j'en vois pas la raison dans ton code
pour te la faire courte
chez moi dir("H:\mes musique\Les 7 ACCORDS jazz manouche à connaître (majeur, mineur, .webm")
malgré que le fichier soit bien là ca ne renvoie rien donc pas d'erreur a gérer
quelle partie de ton code gère ça ?

Dudu2 · 4 Février 2021

Dans la version ci-dessus le fichier apparaît mais dans sa forme dégradée par VBA ou Dir() ou je ne sais quoi.
Dans la version ci-dessous le fichier n'apparaît pas, ce qui est peut-être mieux que de le faire apparaître avec un faux nom. Mais dans les 2 cas on ne règle pas le problème.

VB:

Option Explicit

Sub TestFichiersRépertoireDIR()
    Const Répertoire = "H:" ' "H:\Téléchargements"
    Call FichiersRépertoireDIR(Répertoire)
End Sub

'-------------------------------------------------------------
'Liste des fichiers de l'arborescence complète d'un répertoire
'-------------------------------------------------------------
Function FichiersRépertoireDIR(ByVal NomRépertoire As String, Optional NoRecycle As Boolean = True) As Variant
    Static TabNomsFichiers() As String
    Static NbFichiers As Long
    Dim TabSubFolders() As String
    Dim NbSubFolders As Long
    Dim NomItem As String
    Dim i As Long
    Dim Bool As Boolean
    Dim ErrNumber As Variant
    
    'Appel recursif de cette fonction
    If Left(NomRépertoire, 1) = "|" Then
        NomRépertoire = Mid(NomRépertoire, 2)
        
    'Appel initial
    Else
        Erase TabNomsFichiers
        NbFichiers = 0
    End If
    
    If Right(NomRépertoire, 1) <> "\" Then NomRépertoire = NomRépertoire & "\"
    
    '1er item dans le répertoire
    On Error Resume Next
    NomItem = Dir(NomRépertoire, vbDirectory Or vbSystem Or vbHidden)
    ErrNumber = err.Number
    On Error GoTo 0
    If ErrNumber <> 0 Then Exit Function
    
    Do While Len(NomItem) > 0
        'L'item est un répertoire
        On Error Resume Next
        Bool = (GetAttr(NomRépertoire & NomItem) And vbDirectory) = vbDirectory
        ErrNumber = err.Number
        On Error GoTo 0
        
        If ErrNumber = 0 Then
            'L'item est un répertoire
            If Bool Then
                If NomItem = "." Or NomItem = ".." _
                Or NomItem = "System Volume Information" _
                Or (NoRecycle And NomItem = "$RECYCLE.BIN") Then
                Else
                    NbSubFolders = NbSubFolders + 1
                    ReDim Preserve TabSubFolders(1 To NbSubFolders)
                    TabSubFolders(NbSubFolders) = NomItem
                End If
            
            'L'item est un fichier
            Else
                NbFichiers = NbFichiers + 1
                ReDim Preserve TabNomsFichiers(1 To NbFichiers)
                TabNomsFichiers(NbFichiers) = NomRépertoire & NomItem
            End If
        Else
            'MsgBox "Problème avec le fichier:" & vbCrLf & "<" & NomItem & ">"
        End If
        
        'Item suivant dans le répertoire
        NomItem = Dir()
    Loop
    
    For i = 1 To NbSubFolders
        'Appels recursifs idntifiés par "|" en début du nom de répertoire
        Call FichiersRépertoireDIR("|" & NomRépertoire & TabSubFolders(i), NoRecycle:=NoRecycle)
    Next i
    
    'Return value
    FichiersRépertoireDIR = TabNomsFichiers
End Function

patricktoulon · 4 Février 2021

re
2 minutes j'ai réglé le problème sur le tiens je fini de régler le problème sur le mien et je te donne les deux

patricktoulon · 4 Février 2021

re
voila le tien

VB:

Option Explicit

Sub TestFichiersRépertoireDIR()
    Dim X
    Const Répertoire = "H:" ' "H:\Téléchargements"
    X = FichiersRépertoireDIR(Répertoire)
[A1].Resize(UBound(X)) = Application.Transpose(X)

End Sub

'-------------------------------------------------------------
'Liste des fichiers de l'arborescence complète d'un répertoire
'-------------------------------------------------------------
Function FichiersRépertoireDIR(ByVal NomRépertoire As String, Optional NoRecycle As Boolean = True) As Variant
    Static TabNomsFichiers() As String
    Static NbFichiers As Long
    Dim TabSubFolders() As String
    Dim NbSubFolders As Long
    Dim NomItem As String
    Dim i As Long, q As Long
    Dim Bool As Boolean
    Dim ErrNumber As Variant
    Dim arr1, arr2
    arr1 = Array("a^", "a¨", "a`", "e^", "e¨", "i^", "i¨")
    arr2 = Array("â", "ä", "à", "ê", "ë", "î", "ï")
    'Appel recursif de cette fonction
    If Left(NomRépertoire, 1) = "|" Then
        NomRépertoire = Mid(NomRépertoire, 2)
    'Appel initial
    Else
        Erase TabNomsFichiers
        NbFichiers = 0
    End If
   
    If Right(NomRépertoire, 1) <> "\" Then NomRépertoire = NomRépertoire & "\"
   
    '1er item dans le répertoire
    On Error Resume Next
    NomItem = Dir(NomRépertoire, vbDirectory Or vbSystem Or vbHidden)
    ErrNumber = Err.Number
    On Error GoTo 0
    If ErrNumber <> 0 Then Exit Function
   
    Do While Len(NomItem) > 0
        'L'item est un répertoire
        On Error Resume Next
        Bool = False
        Bool = (GetAttr(NomRépertoire & NomItem) And vbDirectory) = vbDirectory
        ErrNumber = Err.Number
        On Error GoTo 0
       
        'L'item est un répertoire
        If Bool Then
            If NomItem = "." Or NomItem = ".." _
            Or NomItem = "System Volume Information" _
            Or (NoRecycle And NomItem = "$RECYCLE.BIN") Then
            Else
                NbSubFolders = NbSubFolders + 1
                ReDim Preserve TabSubFolders(1 To NbSubFolders)
                TabSubFolders(NbSubFolders) = NomItem
            End If
       
        'L'item est un fichier
        Else
           For q = 0 To UBound(arr1): NomItem = Replace(Replace(NomItem, arr1(q), arr2(q)), UCase(arr1(q)), UCase(arr2(q))): Next
            NbFichiers = NbFichiers + 1
            ReDim Preserve TabNomsFichiers(1 To NbFichiers)
            TabNomsFichiers(NbFichiers) = NomRépertoire & NomItem
        End If
       
        'Item suivant dans le répertoire
        NomItem = Dir()
    Loop
   
    For i = 1 To NbSubFolders
        'Appels recursifs idntifiés par "|" en début du nom de répertoire
        Call FichiersRépertoireDIR("|" & NomRépertoire & TabSubFolders(i), NoRecycle:=NoRecycle)
    Next i
   
    'Return value
    FichiersRépertoireDIR = TabNomsFichiers
End Function

et voila la mienne
comme tu peux le constater les dossier recycle ne déclenche plus d'erreur
c'est pour ca que j'ai un peu plus de fichier que toi

VB:

Sub testx()
    t = DirList("H:\")
    [A1].Resize(UBound(t)) = Application.Transpose(t)
End Sub
Function DirList(Dossier As String, Optional recall As Boolean = False, Optional tbl As Variant) As Variant
    Dim ItemVu As String, directory As Variant, SubFolderCollection As Collection, i As Long, a As Long, E As Long, criteres, arr1, arr2
    Set SubFolderCollection = New Collection
    arr1 = Array("a^", "a¨", "a`", "e^", "e¨", "i^", "i¨"): arr2 = Array("â", "ä", "à", "ê", "ë", "î", "ï")
    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..)
    criteres = vbDirectory Or vbSystem Or vbHidden    'Or vbArchive Or ReadOnly Or vbNormal
    ItemVu = Dir(Dossier, criteres)
    If Error.Number = 0 Then    ' si pas d'erreur on examine le contenu

        'examen  du dossier courrant
        Do While ItemVu <> vbNullString
            If Left(ItemVu, 1) <> "." Then
                On Error Resume Next
                If (GetAttr(Dossier & ItemVu) And vbDirectory) = vbDirectory Then
                                          SubFolderCollection.Add Dossier & ItemVu
                Else
                    For q = 0 To UBound(arr1): ItemVu = Replace(Replace(ItemVu, arr1(q), arr2(q)), UCase(arr1(q)), UCase(arr2(q))): Next
                    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
        For q = 0 To UBound(arr1): subdossier = Replace(Replace(subdossier, arr1(q), arr2(q)), UCase(arr1(q)), UCase(arr2(q))): Next
        If GetAttr(subdossier) <> vbDirectory Then a = UBound(tbl) + 1: ReDim Preserve tbl(1 To a): tbl(a) = subdossier
        DirList subdossier & "\", True, tbl
    Next subdossier
    DirList = tbl
End Function

le problème était simple
en examen du dossier parent le fichier(avec caractere speciaux) ressort en vbdirectory
il etait donc stoker dans le tableau (la collection pour moi) de subdossier
mais lors de l'examen des subdossier comme ça n'en est pas un ça déclenchait une erreur
j'ai aussi mis en place une boucle de replacement des caractères
et même avec ça c'est toujours plus rapide qu'avec FSO
voila une enigme résolu

et je pense que je vais encore simplifier la mienne

patricktoulon · 4 Février 2021

et la voila simplifiée puisque maintenant on sait pourquoi
a savoir :que le test getattr vbdirectory dans un bloc on error resume next executait l'ajout du fichier dans la collection de subdossiers ce qui proquait une sorte "je passe mon tour " avec la gestion d'erreur globale en debut avec le 1er dir
voila qui est réglé avec la 2d gestion d'erreur a l'interieur du bloc (if getattr vbdirectory)
du coup je n'ai plus qu'une seul boucle de replacement

VB:

Sub testx()
    t = DirList("H:\")
    [A1].Resize(UBound(t)) = Application.Transpose(t)
End Sub
Function DirList(Dossier As String, Optional recall As Boolean = False, Optional tbl As Variant) As Variant
    Dim ItemVu As String, ItemVub As String, SubFolderCollection As Collection, i As Long, a As Long, E As Long, criteres, arr1, arr2
    Set SubFolderCollection = New Collection
    arr1 = Array("a^", "a¨", "a`", "e^", "e¨", "i^", "i¨"): arr2 = Array("â", "ä", "à", "ê", "ë", "î", "ï")
    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..)
    criteres = vbDirectory Or vbSystem Or vbHidden    'Or vbArchive Or ReadOnly Or vbNormal
    ItemVu = Dir(Dossier, criteres)
    If Error.Number = 0 Then    ' si pas d'erreur on examine le contenu

        'examen  du dossier courrant
        Do While ItemVu <> vbNullString
            If Left(ItemVu, 1) <> "." Then
               ItemVub = ItemVu: For q = 0 To UBound(arr1): ItemVub = Replace(Replace(ItemVub, arr1(q), arr2(q)), UCase(arr1(q)), UCase(arr2(q))): Next
                  On Error Resume Next
                If (GetAttr(Dossier & ItemVu) And vbDirectory) = vbDirectory Then
                If Err.Number > 0 Then a = UBound(tbl) + 1: ReDim Preserve tbl(1 To a): tbl(a) = Dossier & ItemVub Else SubFolderCollection.Add Dossier & ItemVu: Err.Clear
                Else
                     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
         DirList subdossier & "\", True, tbl
    Next subdossier
    DirList = tbl
End Function

met moi la tienne au propre et j'archive
comme d'habitude on trouve toujours des solutions tout les deux (la fine équipe)

Dudu2 · 4 Février 2021

Ok pour le remplacement des caractères accentués tu peux le conditionner par If ErrNumber <> 0 Then.
Par contre je ne comprends toujours pas ce problème de caractères.
Tu as pu le reproduire sur ton PC ou bien c'est juste mes fichiers qui sont à la ramasse ?

patricktoulon · 4 Février 2021

re
oui j'en ai trouvé 3 fichiers".ico" de ma collection (ico png) dans mon disque il ont des "?" avec des "%" et je ne sais quoi d'autre dans le nom a la sortie
mais ca fait rien on les prends quand même maintenant
il faudra avec l'utilisation alimenter les array en fonction des besoins certainement

comme c'est des collections d'icon téléchargés je suis pas trop étonné

donc non c'est pas toi c'est bien propre a dir de windows que ce soit en vb(a,s),dos c'est pareil l'erreur est la même

patricktoulon · 4 Février 2021

??????????

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

hamzaelhathout

XLDnaute Nouveau

hamzaelhathout

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

Pièces jointes

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Discussions similaires