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

[issatams]

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.

 

[camarchepas]

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 .

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 .

 

[issatams]

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.

 

[gosselien]

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.

 

[camarchepas]

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 .....

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

 

[issatams]

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 ?

 

[camarchepas]

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 ..

 

[issatams]

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

D'accord en tout cas un grand merci!

 

[gosselien]

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