Récupérer la valeur d'une cellule d'un fichier commençant par Le sujet est résolu

Y compris Power BI, Power Query et toute autre question en lien avec Excel
Répondre
C
Caribou
Membre habitué
Membre habitué
Messages : 67
Inscrit le : 8 janvier 2013
Version d'Excel : 2010

Message par Caribou » 20 juin 2018, 20:30

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.
Avatar du membre
i20100
Passionné d'Excel
Passionné d'Excel
Messages : 6'030
Appréciations reçues : 351
Inscrit le : 16 mars 2017
Version d'Excel : 2010

Message par i20100 » 21 juin 2018, 03:06

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
Prenons soins de nous et de notre vaisseau spatial, nous n’en n’avons qu’un ...notre planète terre
isabelle
C
Caribou
Membre habitué
Membre habitué
Messages : 67
Inscrit le : 8 janvier 2013
Version d'Excel : 2010

Message par Caribou » 21 juin 2018, 06:43

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 ?
Avatar du membre
thev
Membre impliqué
Membre impliqué
Messages : 2'668
Appréciations reçues : 222
Inscrit le : 13 juin 2016
Version d'Excel : 2019 FR 64 bits

Message par thev » 21 juin 2018, 10:06

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"
T
Theze
Passionné d'Excel
Passionné d'Excel
Messages : 4'019
Appréciations reçues : 306
Inscrit le : 26 janvier 2011
Version d'Excel : 2007/2019

Message par Theze » 21 juin 2018, 17:17

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
Il vaut mieux un qui sait que cent qui cherchent :wink:

Ce forum étant un lieu de partage, je n'accepte pas les messages privés !
C
Caribou
Membre habitué
Membre habitué
Messages : 67
Inscrit le : 8 janvier 2013
Version d'Excel : 2010

Message par Caribou » 21 juin 2018, 18:30

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 ?
T
Theze
Passionné d'Excel
Passionné d'Excel
Messages : 4'019
Appréciations reçues : 306
Inscrit le : 26 janvier 2011
Version d'Excel : 2007/2019

Message par Theze » 22 juin 2018, 07:11

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
Il vaut mieux un qui sait que cent qui cherchent :wink:

Ce forum étant un lieu de partage, je n'accepte pas les messages privés !
T
Theze
Passionné d'Excel
Passionné d'Excel
Messages : 4'019
Appréciations reçues : 306
Inscrit le : 26 janvier 2011
Version d'Excel : 2007/2019

Message par Theze » 22 juin 2018, 07:25

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
Il vaut mieux un qui sait que cent qui cherchent :wink:

Ce forum étant un lieu de partage, je n'accepte pas les messages privés !
C
Caribou
Membre habitué
Membre habitué
Messages : 67
Inscrit le : 8 janvier 2013
Version d'Excel : 2010

Message par Caribou » 22 juin 2018, 14:45

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

Merci beaucoup à vous trois pour votre aide.

Bonne St-Jean!
Répondre
  • Sujets similaires
    Réponses
    Vues
    Dernier message