Rechercher des fichiers dans les sous repertoires

Le 08/09/2024 à 10:34

Bonjour,

J'espère que tout le monde va bien.

Je rencontre un problème pour récupérer des fichiers dans les sous-répertoires avec VBA. D'après mes recherches, il semble qu'il faille utiliser FileSystemObject, mais je ne vois pas vraiment comment m'y prendre.

Si quelqu'un avait une astuce ou un exemple de code, je lui serais éternellement reconnaissant !

Bonne journée et merci d'avance pour votre aide.

François

Sub Macro1()

Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
 Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
 Dim TS As ListObject 'déclare la variable TS (Tableau Structuré)
 Dim CA As String 'déclare la variable CA (Chemin d'Accès)
 Dim F As String 'déclare la variable F (Fichier)
 Dim CS As Workbook 'déclare la variable CS (Classeur Source)
 Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
 Dim R As Range 'déclare la variable R (Recherche)
 Dim LI As Integer 'déclare la variable LI(LIgne)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran

Set CD = ThisWorkbook 'définit le classeur destination CD
 Set OD = CD.Worksheets("Base de donnée") 'définit l'onglet destination OD
 Set TS = OD.ListObjects("Tableau4") 'définit le tableau structuré TS
 CA = CD.Path & "\" 'définit le chemin d'accès CA
 F = Dir(CA & "*.xls?") 'définit le premier fichier F ayant CA comme chemin d'accès

Do While F <> "" 'exécute tant qu'il existe des fichiers F

If F <> ThisWorkbook.Name Then 'condition : si F n'est pas le fichier destination
 Set CS = Application.Workbooks.Open(CA & F) 'définit le classeur source CS en l'ouvrant
 Set OS = CS.Worksheets(1) 'définit l'onglet source (ici le premier, à adapter à ton cas)
 Set R = TS.ListColumns(1).Range.Find("") 'définit la recherche R (recherche du vide dans la colonne 1 de TS)
 If R Is Nothing Or TS.ListRows.Count = 0 Then 'condition : si aucune accurrence n'est trouvée

TS.ListRows.Add 'ajoute une ligne à TS

LI = TS.ListRows.Count 'définit la ligne LI (dernière ligne de TS)

Else 'sinon

LI = R.Row - TS.HeaderRowRange.Row 'définit la ligne LI (ligne de la première occurrence trouvée moins la ligne des entête)

End If 'fin de la condition

'récupération des données de la fiche

TS.DataBodyRange(LI, 1).Value = OS.Range("B8:P9")(1, 1).Value
 TS.DataBodyRange(LI, 2).Value = OS.Range("AA5:AG5")(1, 1).Value
 TS.DataBodyRange(LI, 3).Value = OS.Range("AA4:AG4")(1, 1).Value
  CS.Close False 'ferme la classeur source sans enregistrer
 End If 'fin de la condition

F = Dir 'définit le prochain fichier F ayant CA comme chemin d'accès

Loop 'boucle

Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran

MsgBox "Données traitées !" 'message

End Sub
Le 08/09/2024 à 11:19

bonjour,

voici un exemple

Sub aargh()
    Dim fs As Object, wsh As Object

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Set fs = CreateObject("scripting.filesystemobject")
    Set wsh = ActiveSheet
    chemin = wsh.Range("B1") & "\" 'prendre chemin en B1 sur la feuille active
    i = 5 'mettre données à partir de la ligne 5
    traiterepertoire wsh, fs, chemin, i ' traiter les fichiers du répertoire
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

Sub traiterepertoire(wsh_result As Object, fs As Object, chemin, ByRef i)
    Set rep = fs.getfolder(chemin)
    For Each Fichier In rep.Files 'on traite les fichiers du répertoire
        If Fichier Like "*.xls*" Then ' fichier excel
            Set wkb_source = Workbooks.Open(Fichier)
            wsh_result.Cells(i, 1) = ActiveWorkbook.Name
            wsh_result.Cells(i, 2) = wkb_source.Sheets("feuil1").[K4]
            wsh_result.Cells(i, 3) = wkb_source.Sheets("feuil2").[K5]
            wsh_result.Cells(i, 4) = wkb_source.Sheets("feuil3").[D38]
            i = i + 1
            wkb_source.Close
        End If
    Next
    For Each sousrep In rep.subFolders 'on traite chacun des sous-répertoires trouvés dans ce répertoire
        traiterepertoire wsh_result, fs, sousrep, i
    Next
End Sub
Le 08/09/2024 à 11:28

Merci pour la réponse !!
malheureusement permission refusée comme résultat :(

Le 08/09/2024 à 12:41

malheureusement permission refusée comme résultat :(

Quel est le chemin (répertoire de départ) que tu as indiqué ? tu peux recevoir ce message si la macro essaie d'accéder à un fichier qui est déjà ouvert (par exemple le fichier qui contient la macro).

tu peux essayer de modifier cette instruction

Set wkb_source = Workbooks.Open(Fichier)

ainsi

Set wkb_source = Workbooks.Open(Fichier, ReadOnly:=True)
Le 08/09/2024 à 12:53

Merci pour les conseils je vais regarder.
En faites, l'idée c'était justement de ne pas indiquer de chemin de départ, pour partir de l'emplacement du fichier

Le 08/09/2024 à 15:38

Bonjour,

Je pense qu'il faut exclure dans la recherche, les répertoires système.

Essayer ce code :

Sub Macro1()

    Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
    Dim TS As ListObject 'déclare la variable TS (Tableau Structuré)
    Dim CA As String 'déclare la variable CA (Chemin d'Accès)
    Dim FSO As Object

    Application.ScreenUpdating = False 'masque les rafraîchissements d'écran

    Set CD = ThisWorkbook 'définit le classeur destination CD
    Set TS = [Tableau4].ListObject 'définit le tableau structuré TS
    Set FSO = CreateObject("Scripting.FileSystemObject") 'Liaison tardive de la classe FileSystemObject

    CA = CD.Path & "\" 'définit le chemin d'accès CA
    rech_fichiers FSO, FSO.GetFolder(CA), TS

    Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran

    MsgBox "Données traitées !" 'message

End Sub

Sub rech_fichiers(ByVal FSO As Object, ByVal dossier As Object, ByVal TS As ListObject)

    Dim sous_dossier As Object, fichier As Object
    Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
    Dim R As Range 'déclare la variable R (Recherche)
    Dim LI As Integer 'déclare la variable LI(LIgne)
    Dim CS As Workbook 'déclare la variable CS (Classeur Source)

    'récupération fichier
    For Each fichier In dossier.Files

        If Not fichier.Name Like "*" & ThisWorkbook.Name _
        And FSO.GetExtensionName(fichier.Path) Like "*xls*" Then  'condition : si fichier n'est pas le fichier destination et est un classeur Excel

            Set CS = Application.Workbooks.Open(fichier.Path) 'définit le classeur source CS en l'ouvrant
            Set OS = CS.Worksheets(1) 'définit l'onglet source (ici le premier, à adapter à ton cas)
            Set R = TS.ListColumns(1).Range.Find("") 'définit la recherche R (recherche du vide dans la colonne 1 de TS)
            If R Is Nothing Or TS.ListRows.Count = 0 Then 'condition : si aucune occurrence n'est trouvée

                TS.ListRows.Add 'ajoute une ligne à TS

                LI = TS.ListRows.Count 'définit la ligne LI (dernière ligne de TS)

            Else 'sinon

                LI = R.Row - TS.HeaderRowRange.Row 'définit la ligne LI (ligne de la première occurrence trouvée moins la ligne des entête)

            End If 'fin de la condition

        'récupération des données de la fiche

            TS.DataBodyRange(LI, 1).Value = OS.Range("B8:P9")(1, 1).Value
            TS.DataBodyRange(LI, 2).Value = OS.Range("AA5:AG5")(1, 1).Value
            TS.DataBodyRange(LI, 3).Value = OS.Range("AA4:AG4")(1, 1).Value

            CS.Close False 'ferme la classeur source sans enregistrer

        End If 'fin de la condition

    Next

    'boucle récursive pour sous-dossiers
    For Each sous_dossier In dossier.SubFolders
        IF sous_dossier.Attributes <> vbDirectory + vbSystem + vbHidden Then rech_fichiers FSO, sous_dossier, TS
    Next

End Sub
Rechercher des sujets similaires à "rechercher fichiers repertoires"