Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

Récupérer la valeur d'une cellule en bas d'une cellule dont la valeur est connu

Créer une discussion

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
I

issatams

XLDnaute Nouveau
Tout d'abord bonjour,
voila j'explique mon problème j'ai un dossier avec quelques centaines de fichiers et j'aimerais pouvoir récupérer le nom du client de chaque fichier. Cependant ce nom n'est pas toujours au même endroit j'aimerais donc à l'aide d'une macro faire une recherche sur chaque feuille et trouver la cellule dont la valeur est "client" et prendre la cellule juste en dessous (qui contient toujours le nom du Client) et de la remettre dans un tableau récapitulatif de tout mes fichiers. Voila j'espère avoir était clair et je vous remercie d'avance pour vos réponses.
 
Trier par date Trier par votes
Re : Récupérer la valeur d'une cellule en bas d'une cellule dont la valeur est connu

Bonjour et bienvenue sur Xld,

As-tu un début de code pour le reste de ta demande, voir un fichier ?

Sauf embuche ex Cellules fusionnées ou autre, voici déjà le code pour retrouver le nom du client .

Code: 
Sub Cherche()
Dim Trouve As Range

Set Trouve = Cells.Find("Client", lookat:=xlWhole)
If Trouve Is Nothing Then
  MsgBox "Pas de référence client trouvée"
 Else
  MsgBox "Client : " & Trouve.Offset(1, 0)
End If


End Sub

Ensuite , il faudrait nous donner :

L'arbo de recherche des fichiers

un fichier avec un exemple de tableau récap

et un exemple anonymisé de la fiche client afin de confirmer la routine de recherche .
 
Vote positif 0 Vote négatif
Re : Récupérer la valeur d'une cellule en bas d'une cellule dont la valeur est connu

Bonjour ,
merci pour la rapidité de votre réponse, en fait j'ai déjà essayé de réadapter un code trouver sur un forum je vous envoie un exemple de fichier avec le fichier récapitulatif, le problème est qu'il me met une erreur lorsque je lance la macro.
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
Re : Récupérer la valeur d'une cellule en bas d'une cellule dont la valeur est connu

Bonjour,

tu as la possibilté d'ouvrir tous les classeurs en un fois ou tu dois scanner un répertoire ?
ça semble important et plus probable si tu parles de centaines de fichiers...

P.
 
Vote positif 0 Vote négatif
Re : Récupérer la valeur d'une cellule en bas d'une cellule dont la valeur est connu

Re ,

@ Bonjour Gosselien : Et trés bonne remarque, la mémoire n'étant pas infinie , surtout avec Excel

J'ai remis un peu d'ordre dans tout cela .

Entre autre thisworksheet n'existe pas .....

Code: 
Private Function ChoisirDossier() As String
Dim objShell As Object, objFolder As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Sélectionnez un Dossier", &H1&)
On Error Resume Next
ChoisirDossier = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
If Err.Number <> 0 Then ChoisirDossier = ""
On Error GoTo 0
End Function
Sub GrouperDataFichiers()

Dim FSO 'As Scripting.FileSystemObject
Dim SourceFolder As Object 'As Scripting.Folder
Dim FileItem As Object 'As Scripting.File
Dim chemin$
Dim T()
Dim cpt&, g&, i&, j&, Lig&
Dim Z As Range
Dim W
Dim Vari As Variant
Dim WB As Workbook
Dim S As Worksheet, DEST As Worksheet
Dim Info(1 To 1, 1 To 26) As Variant
'------------
chemin$ = ChoisirDossier
If chemin$ = "" Then Exit Sub
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(chemin$)
If SourceFolder.Files.Count = 0 Then Exit Sub
For Each FileItem In SourceFolder.Files
  If LCase(Right(FileItem.Name, 4)) = ".xls" Then
    cpt& = cpt& + 1
    ReDim Preserve T(1 To cpt&)
    T(cpt&) = chemin$ & "\" & FileItem.Name
  End If
Next FileItem
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
'------------
Application.ScreenUpdating = False
Set DEST = ActiveSheet
Lig& = 1
For g& = 1 To UBound(T)
  Set WB = GetObject(T(g&))
  Set S = WB.Sheets("Montage")
  Set Z = S.Cells.Find("CLIENT")
  If Z Is Nothing Then
    MsgBox "Pas de réf client"
   Else
    Info(1, 1) = Z.Offset(1, 0)
  End If
  
  WB.Close (False)
  Set S = Nothing
  Set Z = Nothing
  Set WB = Nothing
  Lig& = Lig& + 1
  DEST.Range(DEST.Cells(Lig&, 1), DEST.Cells(Lig&, UBound(Info, 2))) = Info
  Erase Info
Next g&

Vari = Array("client", "ref", "moule", "designation", "Nb empreinte", "machine", "diametre")
With DEST
  .Range(.Cells(1, 1), .Cells(1, UBound(Vari) + 1)) = Vari
End With
Set DEST = Nothing
Application.ScreenUpdating = True
End Sub
 
Vote positif 0 Vote négatif
Re : Récupérer la valeur d'une cellule en bas d'une cellule dont la valeur est connu

Non je dois scanner un répertore j'ai environ 1500 fichier.

MERCI !!!!!!!!!!!!!!!!!!!!!!!! camarchepas ! cela marche je t'en dois une tu es mon sauveur. Juste par curiosité d'ou venais le problème au final ?
 
Vote positif 0 Vote négatif
Re : Récupérer la valeur d'une cellule en bas d'une cellule dont la valeur est connu

1) Set Z = S.Find("CLIENT") => set Z = S.cells.find("CLIENT")
2) Set DEST = thisworksheet => set DEST = Activesheet


3) var est un nom de variable à éviter
4) Déclaration des variables plus ou moins aléatoire
5) Utilisation des controles erreur un peu Olé olé

Voilà au final , mais c'est dans la macro , donc pour progresser , à analyser ..
 
Vote positif 0 Vote négatif
Re : Récupérer la valeur d'une cellule en bas d'une cellule dont la valeur est connu

Bonjour,

autre version, moins affinée mais qui semble fonctionner , recherche autre d'un mot possible et adresse de celui ci dans les différents classeurs
les fichiers avec le nom de client doivent être dans "c:\temp" mais pas celui avec ta page de garde

Patrick


Sub TrouverClient() ' avec dictionnaire
Application.ScreenUpdating = False
' compte et place en A2 une SEULE occurence
' dans une nouvelle feuille avec l'adresse
' de tous les exemplaires trouvés de la même occurence
' test ebec info supplémentaire sur la cellule (longueur de la chaine)
Application.ScreenUpdating = False
Dim DEST As Range
Set dico = CreateObject("Scripting.Dictionary")
Dim Zone, Mwb
Dim Mcom, Chemin
Dim NbItem As Integer
Dim WS1 As Worksheet, Ws2 As Worksheet
Dim Lastcell
Dim Trouve 'item trouvé oui/non
Dim Adr ' adresse de la cellume
Dim CléCom 'commentaire --> adresse de la 1ere cellule
Dim Texte As String
Dim Quest As String
Quest = InputBox("Quel texte à chercher ?", "Chercher", "client", vbYesNo)
If Len(Quest) = 0 Then Exit Sub
'Texte = "@" ' chercher adresse Mail
Set WS1 = ActiveSheet ' feuille de départ
Colonne1Vide = Application.CountA(Columns(1)) = 0
If Not Colonne1Vide Then
Sheets.Add after:=Sheets(1)
Set Ws2 = ActiveWorkbook.ActiveSheet 'nouvelle feuille pour ne rien effacer
Set DEST = ActiveSheet.Range("A1")
'[A1] = ActiveSheet.Name
Else
Set DEST = WS1.Range("A1")
End If
Set Ws2 = ActiveWorkbook.ActiveSheet
Dim Fichier As String
'Définit le répertoire contenant les fichiers
Chemin = "C:\temp\"
Dim Fil As Integer
'Boucle sur tous les fichiers xls du répertoire.
Fichier = Dir(Chemin & "*.xl*")
Do While Len(Fichier) > 0
Fil = Fil + 1
'écrit le résultat dans la fenêtre d'exécution (Ctrl+G).
Cells(Fil, 1).Value = Fichier
'Debug.Print Chemin & Fichier
Fichier = Dir()
Loop
If Fil = 0 Then Exit Sub
Ws2.Activate ' retour feuille1
For Each cell In Range("A1:A" & Ws2.[A65000].End(xlUp).Row)
Fic = Chemin & cell.Value
Set WB = Workbooks.Open(Fic)
'[A1].Select
Selection.SpecialCells(xlCellTypeConstants, 2).Select
With Selection ' .SpecialCells(xlCellTypeConstants, 2)
On Error Resume Next
Set c = .Find(What:=Quest, LookIn:=xlValues, LookAt:=xlPart)
Dim Cli As Integer ' nb de "clients"
If Not c Is Nothing Then
FirstAddress = c.Address
Do
Cli = Cli + 1
clé = c.Offset(1, 0) ' valeur de la cellule dessous
Adr = c.Address(0, 0) & "-" ' adresse de la cellule
mcoul = c.Offset(1, 0) ' nom
Mwb = ActiveWorkbook.FullName
' on sépare les data par un ","
'Dico(clé) = c.Interior.Color & "." & c.Address(0, 0) & "." & Len(c) & "." & c.Font.Name
' couleur en 1, adresse en 2, ' longueur en 3, police en 4
dico(clé) = dico(clé) & "," & mcoul & "," & c.Address(0, 0) & "," & Mwb
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
WB.Close (False)
Next ' each cell
If dico.Count = 0 Then Exit Sub
' déposer les items trouvés sur la zone prévue (A2 de feuille Destination)
a = dico.Keys ' ARRAY
B = dico.Items ' ARRAY
If Not Colonne1Vide Then Ws2.Select
For i = 0 To UBound(a)
With ActiveSheet
.Cells(i + 1, 2) = a(i) ' sous le titre en 2e ligne
S = Split(B(i), ",")
.Cells(i + 1, 2).Interior.Color = S(0) ' couleur
.Cells(i + 1, 2).AddComment Text:=S(3) ' adresse
.Cells(i + 1, 3).Value = S(2) ' adresse des nb occurences trouvées
.Cells(i + 1, 2).Comment.Visible = False
.Cells(i + 1, 2).Comment.Shape.TextFrame.AutoSize = True
.Cells(i + 1, 4).Value = S(3)
End With
Next i
End
Columns("A:F").EntireColumn.AutoFit
End Sub
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

D
  • Résolu(e)
Microsoft 365 vba récupérer valeur cellule d'une autre feuille
Réponses
3
Affichages
283
Diane272727
D
M
  • Résolu(e)
XL 2021 Récupérer la valeur d’une cellule dans un classeur fermé
Réponses
5
Affichages
271
patricktoulon
A
  • Question Question
XL 2021 Comment préserver la première valeur d'une cellule uniquement si
2 3
Réponses
34
Affichages
1 K
Alamyr
A
D
  • Résolu(e)
Microsoft 365 Récupérer la valeur d'une cellule d'un autre fichier
Réponses
7
Affichages
492
Diane272727
D
F
  • Question Question
Autres Récupération de données d'une feuille X en fonction de la valeur de cellule dans une collone d'une feuille Y
2
Réponses
27
Affichages
1 K
fanfan38
C
  • Question Question
XL 2016 récupérer la mise en forme d'une cellule vers une autre cellule
Réponses
1
Affichages
488
TooFatBoy
A
  • Question Question
XL 2016 Récupérer la valeur d'une cellule en fonction de 2 conditions
Réponses
6
Affichages
457
Ariellab
A
J
  • Question Question
XL 2010 définir un nom de cellule en fonction de la valeur d'une autre
Réponses
12
Affichages
1 K
jojo4738
J
D
  • Question Question
Microsoft 365 Récupérer une valeur présente dans un autre fichier dont le chemin et le nom est présent dans une cellule
Réponses
6
Affichages
306
wDog66
W
M
  • Résolu(e)
XL 2010 Ressortir uniquement les nombres de la musique d'une course hippique
Réponses
5
Affichages
283
mamarus1
M
S
  • Question Question
XL 2013 enregistrer une feuille excel converti en pdf dans un répertoire selon la valeur d'une cellule
Réponses
5
Affichages
579
Phil69970
J
  • Question Question
Microsoft 365 Mini macro en VBA
Réponses
1
Affichages
272
jderoque
J
  • Résolu(e)
XL 2016 En VBA, Automatiser la réponse en fonction de l'état d'une cellule.
Réponses
7
Affichages
716
piga25
I
  • Résolu(e)
Microsoft 365 Exécuter une macro en fonction de la valeur d'une cellule
Réponses
12
Affichages
811
iliess
I
  • Résolu(e)
Microsoft 365 Remplir une cellule avec la valeur d'une autre sous condition
Réponses
2
Affichages
546
Droopyougo
W
  • Question Question
XL 2019 Récupérer le nom d'une feuille où se trouve une valeur précise
Réponses
5
Affichages
663
Winnylourson
W
P
  • Résolu(e)
XL 2021 Requête API - VBA Excel - Parse JSON
Réponses
2
Affichages
607
picc
P
A
  • Question Question
Microsoft 365 créer un lien vers une cellule dont la ligne est fluctuante
Réponses
3
Affichages
278
AtTheOne
A
  • Résolu(e)
Microsoft 365 Enregistrer copie d'un fichier avec pour nom le contenu d'une cellule excel (macro)
2
Réponses
15
Affichages
1 K
firecarl
F
  • Question Question
XL 2021 VBA Ajout d'une valeur en heure dans une cellule
2
Réponses
21
Affichages
998
TooFatBoy
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…