Récupérer la valeur d'une cellule d'un fichier commençant par

Bonjour Forum,

Je ne suis pas sûr qu'il faille passer par une macro pour cela mais toutes les solutions me vont.

J'ai un dossier 1 dans lequel se trouve un fichier Excel (à la racine donc) dans lequel je cherche à récupérer dans une colonne la valeur de la cellule A5 de tous les fichiers Excel commençant par "Rapport 2018" qui se trouvent dans des sous-dossiers de ce dossier 1.

Merci d'avance pour votre aide !

y.

Bonjour,

voici un exemple,

Sub lireFichiers()
    'Nécessite d'activer la référence Microsoft Shell Controls and Automation
    Dim objShell As Shell32.Shell
    Dim strFileName As Shell32.FolderItem
    Dim objFolder As Shell32.Folder
    Dim rep As String, vSheet As String, rng As String, x As Integer

    rep = "C:\Users\isabelle\Documents\"    'adapter le chemin
    vSheet = "Feuil1"    'adapter le nom de l'onglet
    rng = Range("A5").Address(, , xlR1C1)
    x = 2

    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(rep)

    For Each strFileName In objFolder.Items
     If strFileName.isFolder = False Then
        If Left(strFileName,12) = "Rapport 2018" Then
          Range("A" & x) = ExecuteExcel4Macro("'" & rep & "[" & strFileName & "]" & vSheet & "'!" & rng)
        End If
     End If
     x = x + 1
    Next
End Sub

Allo sabV,

merci beaucoup pour ton aide.

La macro bloque sur Dim objShell As Shell32.Shell. J'ai le message suivant User-defined type not defined.

Aurais-tu une idée ?

Bonjour Caribou, Sabv

Deux solutions :

1- ajouter la référence de la bibliothèque "Microsoft Shell Controls et Automation" dans l'éditeur VBA --> Outils --> Références

2- remplacer "Shell32.Shell" par "Object"

Bonjour,

Une autre piste. Les feuilles des différents classeurs portent toutes le même nom, le code ci-dessous est collé dans le classeur qui se trouve dans le dossier "racine" J'ai un dossier 1 dans lequel se trouve un fichier Excel (à la racine donc), les valeurs récupérées sont entrée en colonne A à partir de A1 ! A tester en lançant la procédure "RecupDonnees" après avoir adapté le nom des feuilles (ne pas modifier les fonctions appelées !) :

Sub RecupDonnees()

    Dim Tbl() As String
    Dim I As Integer

    'le chemin du dossier "racine" est le chemin du classeur où se trouve ce code-ci !
    Tbl = RecupFichiers(ThisWorkbook.Path)

    If Not Not Tbl() Then

        For I = 1 To UBound(Tbl, 2)

            Cells(I, 1).Value = RecupValeur(Tbl(1, I), Tbl(2, I), "Feuil1", "A5") '<--- adapter le nom des feuilles !

        Next I

    End If

End Sub

Function RecupFichiers(Dossier As String) As String()

    Dim Fso As Object
    Dim Dos As Object
    Dim D As Object
    Dim Tbl() As String
    Dim Fichier As String
    Dim I As Long

    Set Fso = CreateObject("Scripting.FileSystemObject")

    If Right(Dossier, 1) <> "\" Then Dossier = Dossier & "\"

    If Fso.FolderExists(Dossier) = False Then Exit Function

    Set Dos = Fso.GetFolder(Dossier)

    'boucle sur les sous-dossiers
    For Each D In Dos.SubFolders

        Fichier = Dir(D.Path & "\" & "Rapport 2018*")

        Do While (Len(Fichier) > 0)

            I = I + 1: ReDim Preserve Tbl(1 To 2, 1 To I)
            Tbl(1, I) = D.Path & "\"
            Tbl(2, I) = Fichier

            Fichier = Dir()

        Loop

    Next D

    RecupFichiers = Tbl

End Function

Function RecupValeur(Chemin As String, _
                     NomClasseur As String, _
                     NomFeuille As String, _
                     Cellule As String)

    Dim Arg As String

    'si c'est une plage, affiche un message et fin de procédure
    If InStr(Cellule, ":") Then

        MsgBox "Une seule cellule en argument", , "Cellule unique."
        Exit Function

    End If

    'ignore l'erreur si la plage est déjà en référence R1C1
    On Error Resume Next
    'transforme la référence en style R1C1
    Cellule = Range(Cellule).Address(, , xlR1C1)

    'construit l'argument
    Arg = "'" & Chemin & "[" & NomClasseur & "]" & NomFeuille & "'!" & Cellule

    'passe la valeur à la fonction
    RecupValeur = Application.ExecuteExcel4Macro(Arg)

End Function

Bonjour Theze,

Ça marche vraiment bien pour le premier niveau de sous-dossier. Est-il possible de forcer la recherche dans les autres niveaux de sous-dossiers ?

Bonjour,

Pour ça, remplace la fonction "RecupFichiers()" qui reste sur le même plan de dossiers par la Sub "RecupFichiers" récursive ci-dessous qui ira chercher jusque dans les sous-dossiers les plus bas :

Sub RecupFichiers(Dossier As String, Tbl() As String)

    Dim Fso As Object
    Dim Dos As Object
    Dim D As Object
    Dim Fichier As String

    Set Fso = CreateObject("Scripting.FileSystemObject")

    If Right(Dossier, 1) <> "\" Then Dossier = Dossier & "\"

    If Fso.FolderExists(Dossier) = False Then Exit Sub

    Set Dos = Fso.GetFolder(Dossier)

    'boucle sur les sous-dossiers
    For Each D In Dos.SubFolders

        Fichier = Dir(D.Path & "\" & "Rapport 2018*")

        Do While (Len(Fichier) > 0)

            On Error Resume Next 'évite l'erreur du tableau non initialisé
            ReDim Preserve Tbl(1 To 2, 1 To UBound(Tbl, 2) + 1)
            If Err.Number <> 0 Then ReDim Tbl(1 To 2, 1 To 1)
            On Error GoTo 0

            Tbl(1, UBound(Tbl, 2)) = D.Path & "\"
            Tbl(2, UBound(Tbl, 2)) = Fichier

            Fichier = Dir()

        Loop

        RecupFichiers D.Path, Tbl()

    Next D

End Sub

Petit rectificatif !

Comme il ne sert à rien de re-créer l'objet FSO donc, le déclarer en tête de module pour l'initialiser qu'une seule fois. Je te re-poste tout le code :

Dim Fso As Object
Dim Dos As Object
Dim D As Object
Dim Fichier As String

Sub RecupDonnees()

    Dim Tbl() As String
    Dim I As Integer

    Set Fso = CreateObject("Scripting.FileSystemObject")

    'le chemin du dossier "racine" est le chemin du classeur où se trouve ce code-ci !
    RecupFichiers ThisWorkbook.Path, Tbl

    If Not Not Tbl() Then

        For I = 1 To UBound(Tbl, 2)

            Cells(I, 1).Value = RecupValeur(Tbl(1, I), Tbl(2, I), "Feuil1", "A5") '<--- adapter le nom des feuilles !

        Next I

    End If

End Sub

Sub RecupFichiers(dossier As String, Tbl() As String)

    If Right(dossier, 1) <> "\" Then dossier = dossier & "\"

    If Fso.FolderExists(dossier) = False Then Exit Sub

    Set Dos = Fso.getfolder(dossier)

    'boucle sur les sous-dossiers
    For Each D In Dos.subfolders

        Fichier = Dir(D.Path & "\" & "Rapport 2018*")

        Do While (Len(Fichier) > 0)

            On Error Resume Next 'évite l'erreur du tableau non initialisé
            ReDim Preserve Tbl(1 To 2, 1 To UBound(Tbl, 2) + 1)
            If Err.Number <> 0 Then ReDim Tbl(1 To 2, 1 To 1)
            On Error GoTo 0

            Tbl(1, UBound(Tbl, 2)) = D.Path & "\"
            Tbl(2, UBound(Tbl, 2)) = Fichier

            Fichier = Dir()

        Loop

        RecupFichiers D.Path, Tbl()

    Next D

End Sub

Function RecupValeur(chemin As String, _
                     NomClasseur As String, _
                     NomFeuille As String, _
                     Cellule As String)

    Dim Arg As String

    'si c'est une plage, affiche un message et fin de procédure
    If InStr(Cellule, ":") Then

        MsgBox "Une seule cellule en argument", , "Cellule unique."
        Exit Function

    End If

    'ignore l'erreur si la plage est déjà en référence R1C1
    On Error Resume Next
    'transforme la référence en style R1C1
    Cellule = Range(Cellule).Address(, , xlR1C1)

    'construit l'argument
    Arg = "'" & chemin & "[" & NomClasseur & "]" & NomFeuille & "'!" & Cellule

    'passe la valeur à la fonction
    RecupValeur = Application.ExecuteExcel4Macro(Arg)

End Function

Comme d'habitude, ce forum est d'une aide inestimable.

Merci beaucoup à vous trois pour votre aide.

Bonne St-Jean!

Rechercher des sujets similaires à "recuperer valeur fichier commencant"