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

H

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
H
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...
Trier par date Trier par votes
patricktoulon

patricktoulon

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
Dudu2

Dudu2

XLDnaute Barbatruc
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.
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
?????????
demo7.gif
 
Vote positif 0 Vote négatif
Dudu2

Dudu2

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
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 à connaî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 ?
 
Vote positif 0 Vote négatif
Dudu2

Dudu2

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
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)
 
Vote positif 0 Vote négatif
Dudu2

Dudu2

XLDnaute Barbatruc
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 ?
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif

Discussions similaires

M
  • Question
XL 2019 Transposer des données d'une feuille vers une autre sous forme de synthèse
Réponses
8
Affichages
262
mromain
mromain
edgy63
  • Question
Microsoft 365 Remplir cellules à partir de plusieurs fichiers Excel d'un dossier
2
Réponses
17
Affichages
500
alexga78
A
F
  • Question
XL 2021 Liste déroulante vers un autre classeur
Réponses
1
Affichages
322
Dudu2
Dudu2
vgendron
  • Question
Power Query [Resolu] Importer plusieurs fichiers excel provenant de dossiers différents sur sharepoint
Réponses
6
Affichages
1 K
Staple1600
Staple1600
T
  • Question
XL 2010 VAB - Copier les fichiers manquants d'un dossier et de ses sous-dossiers
Réponses
2
Affichages
396
Titi456
T
N
  • Résolu(e)
XL pour MAC Erreur à l'enregistrement de plusieurs fichiers Excel
Réponses
5
Affichages
157
Noymie
N
V
  • Question
XL 2021 Implémenter tableau avec des fichiers mis dans un dossier
Réponses
2
Affichages
328
merinos-BernardEtang
merinos-BernardEtang
F
  • Question
XL 2016 copier des fichiers dans des sous dossiers a partir de case a cocher sous excel
2
Réponses
17
Affichages
1 K
Felipe54
F
T
  • Résolu(e)
XL 2010 Bouton - Supprimer photos JPG dans un dossier et ses sous-dossiers
Réponses
9
Affichages
621
Titi456
T
D
  • Résolu(e)
Outlook Macro Outlook 365-Création sous-dossier suivant contenu et sauvegarde pièces jointes lien zip
2
Réponses
29
Affichages
450
DELATTE
D

Membres actuellement en ligne

2 membres et 50 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 097
Messages
2 116 186
Membres
112 679
dernier inscrit
Yupanki