Récuperer la valeur d'une cellule en bas d'une cellule cherché
Fermé
issatams
Messages postés
2
Date d'inscription
samedi 14 février 2015
Statut
Membre
Dernière intervention
14 février 2015
-
Modifié par issatams le 14/02/2015 à 01:25
issatams Messages postés 2 Date d'inscription samedi 14 février 2015 Statut Membre Dernière intervention 14 février 2015 - 14 févr. 2015 à 11:50
issatams Messages postés 2 Date d'inscription samedi 14 février 2015 Statut Membre Dernière intervention 14 février 2015 - 14 févr. 2015 à 11:50
A voir également:
- Récuperer la valeur d'une cellule en bas d'une cellule cherché
- Aller à la ligne dans une cellule excel - Guide
- Verrouiller cellule excel - Guide
- Excel cellule couleur si condition texte - Guide
- Récupérer une vidéo youtube - Guide
- Excel renvoyer la valeur d'une cellule en fonction d'une autre ✓ - Forum Excel
2 réponses
jordane45
Messages postés
38197
Date d'inscription
mercredi 22 octobre 2003
Statut
Modérateur
Dernière intervention
30 mai 2024
4 675
14 févr. 2015 à 02:09
14 févr. 2015 à 02:09
Bonjour,
Tu peux utiliser la méthode FIND.
voici un exemple : https://forums.commentcamarche.net/forum/affich-37621992-methode-find-dans-vba-recherche-de-donnees-sous-excel
Tu peux utiliser la méthode FIND.
voici un exemple : https://forums.commentcamarche.net/forum/affich-37621992-methode-find-dans-vba-recherche-de-donnees-sous-excel
issatams
Messages postés
2
Date d'inscription
samedi 14 février 2015
Statut
Membre
Dernière intervention
14 février 2015
14 févr. 2015 à 11:50
14 févr. 2015 à 11:50
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, le problème est qu'il me met une erreur lorsque je lance la macro. ci dessous le code
Private Function ChoisirDossier() As String
Dim objShell
Dim objFolder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder _
(&H0&, "Sélectionnez un Dossier", &H1&)
On Error GoTo Erreur
ChoisirDossier = objFolder.ParentFolder _
.ParseName(objFolder.Title).Path & ""
Exit Function
Erreur:
ChoisirDossier = ""
End Function
Sub GrouperDataFichiers()
Dim FSO 'As Scripting.FileSystemObject
Dim SourceFolder 'As Scripting.Folder
Dim FileItem 'As Scripting.File
Dim chemin$
Dim T()
Dim cpt&
Dim g&
Dim i&
Dim j&
Dim Lig&
Dim Z
Dim W
Dim var
Dim WB As Workbook
Dim S As Worksheet
Dim DEST As Worksheet
Dim Info(1 To 1, 1 To 26)
'------------
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 = thisworksheet
Lig& = 1
For g& = 1 To UBound(T)
Set WB = GetObject(T(g&))
Set S = WB.Sheets("Montage")
Set Z = S.Find("CLIENT")
If Z Is Nothing Then
MsgBox "Pas de réf client"
Else
Info(1, 1) = Z.Offset(1, 0)
End If
var = Array("", "b", "c", "f")
WB.Close (False)
Set WB = Nothing
Lig& = Lig& + 1
DEST.Range(DEST.Cells(Lig&, 1), _
DEST.Cells(Lig&, UBound(Info, 2))) = Info
Erase Info
Next g&
var = Array("client", "ref", "moule" _
, "designation", "Nb empreinte", "machine", "diametre")
With DEST
.Range(.Cells(1, 1), .Cells(1, UBound(var) + 1)) = var
End With
Application.ScreenUpdating = False
Exit Sub
Erreur:
Application.ScreenUpdating = False
MsgBox "Erreur " & Err.Number & vbCrLf & Err.Description
End Sub
merci pour la rapidité de votre réponse, en fait j'ai déjà essayé de réadapter un code trouver sur un forum, le problème est qu'il me met une erreur lorsque je lance la macro. ci dessous le code
Private Function ChoisirDossier() As String
Dim objShell
Dim objFolder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder _
(&H0&, "Sélectionnez un Dossier", &H1&)
On Error GoTo Erreur
ChoisirDossier = objFolder.ParentFolder _
.ParseName(objFolder.Title).Path & ""
Exit Function
Erreur:
ChoisirDossier = ""
End Function
Sub GrouperDataFichiers()
Dim FSO 'As Scripting.FileSystemObject
Dim SourceFolder 'As Scripting.Folder
Dim FileItem 'As Scripting.File
Dim chemin$
Dim T()
Dim cpt&
Dim g&
Dim i&
Dim j&
Dim Lig&
Dim Z
Dim W
Dim var
Dim WB As Workbook
Dim S As Worksheet
Dim DEST As Worksheet
Dim Info(1 To 1, 1 To 26)
'------------
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 = thisworksheet
Lig& = 1
For g& = 1 To UBound(T)
Set WB = GetObject(T(g&))
Set S = WB.Sheets("Montage")
Set Z = S.Find("CLIENT")
If Z Is Nothing Then
MsgBox "Pas de réf client"
Else
Info(1, 1) = Z.Offset(1, 0)
End If
var = Array("", "b", "c", "f")
WB.Close (False)
Set WB = Nothing
Lig& = Lig& + 1
DEST.Range(DEST.Cells(Lig&, 1), _
DEST.Cells(Lig&, UBound(Info, 2))) = Info
Erase Info
Next g&
var = Array("client", "ref", "moule" _
, "designation", "Nb empreinte", "machine", "diametre")
With DEST
.Range(.Cells(1, 1), .Cells(1, UBound(var) + 1)) = var
End With
Application.ScreenUpdating = False
Exit Sub
Erreur:
Application.ScreenUpdating = False
MsgBox "Erreur " & Err.Number & vbCrLf & Err.Description
End Sub
