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 ?
- Messages
- 4'086
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
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!