Rechercher une valeur sur plusieurs lignes
Résolu
siamens_duj
Messages postés
212
Statut
Membre
-
siamens_duj Messages postés 212 Statut Membre -
siamens_duj Messages postés 212 Statut Membre -
Bonjour,
j'ai fais un code qui me permet de rechercher une valeur entré dans une inputbox.
Si ce qui est entré dans l'inputbox correspond à une valeur de ma cellule B alors je
sélectionne la valeur en cellule A qui est le nom d'un fichier. J'ouvre ensuite ce fichier
et je recherche une valeur ($cahier) en colonne B. Si la valeur est présente alors je copie certaines
valeurs de cette ligne dans ma première feuille de mon classeur sinon j'affiche un message
d'erreur.
Le problème est que la valeur que je recherche dans la feuille ouverte est parfois présente sur
plusieurs lignes.
J'aimerais donc que mon programme récupère toutes les valeurs demandé lorsque $cahier est présent.
J'ai essayé avec plusieurs code mais impossible de trouver la solution.
Si quelqu'un pouvait m'aiguiller svp.
j'ai fais un code qui me permet de rechercher une valeur entré dans une inputbox.
Si ce qui est entré dans l'inputbox correspond à une valeur de ma cellule B alors je
sélectionne la valeur en cellule A qui est le nom d'un fichier. J'ouvre ensuite ce fichier
et je recherche une valeur ($cahier) en colonne B. Si la valeur est présente alors je copie certaines
valeurs de cette ligne dans ma première feuille de mon classeur sinon j'affiche un message
d'erreur.
Le problème est que la valeur que je recherche dans la feuille ouverte est parfois présente sur
plusieurs lignes.
J'aimerais donc que mon programme récupère toutes les valeurs demandé lorsque $cahier est présent.
J'ai essayé avec plusieurs code mais impossible de trouver la solution.
Si quelqu'un pouvait m'aiguiller svp.
Sub recherche()
Dim i As Long
Dim j As Long
Dim l As Long
Dim req As String
Dim Fichier As String
Dim CheminFichier As String
Dim celluletrouvee As Range
Dim indice As String
Dim ligne As Long
Dim col As Long
CheminFichier = "C: ..."
re:
req = InputBox("Renseignez un nom")
If req = "" Then
MsgBox "Vous n'avez rien saisie"
GoTo re
End If
If req <> "" Then
Application.ScreenUpdating = False
i = 2
j = 2
l = 1
Do While Sheets("donnees").Cells(i, 2).Value <> ""
If req = Sheets("donnees").Cells(i, 2).Value Then
Fichier = Sheets("donnees").Cells(i, 1).Value
Workbooks.Open (CheminFichier & Fichier)
indice = "$cahier"
Set celluletrouvee = Range("B16:B100").Find(indice, lookat:=xlWhole)
If celluletrouvee Is Nothing Then
MsgBox ("Aucun nom ne correspond")
Else
ligne = celluletrouvee.Row 'k
col = celluletrouvee.Column
kol:
Workbooks("Programme.xlsm").Sheets("Inv").Cells(j, l).Value = Cells((ligne - 1), (col + 1)).Value
Workbooks("Programme.xlsm").Sheets("Inv").Cells(j, (l + 1)).Value = Cells((ligne - 1), (col + 3)).Value
Workbooks("Programme.xlsm").Sheets("Inv").Cells(j, (l + 2)).Value = Cells((ligne - 1), (col + 4)).Value
Workbooks("Programme.xlsm").Sheets("Inv").Cells(j, (l + 3)).Value = Cells((ligne - 1), (col + 5)).Value
Workbooks("Programme.xlsm").Sheets("Inv").Cells(j, 5).Value = Workbooks("Programme.xlsm").Sheets("donnees").Cells(i, 1).Value
ligne = ligne + 1
If celluletrouvee <> "" Then
Do While Workbooks("Programme.xlsm").Sheets("Inv").Cells(j, l).Value <> ""
l = l + 1
Loop
GoTo kol
End If
Workbooks(Fichier).Close (True)
End If
j = j + 1
End If
i = i + 1
Loop
end if
end Sub
4 réponses
-
Bonjour,
Juste pour le problème Valeur sur plusieurs lignes
déclarations:Dim Plage as range
Dim Ligne as Byte 'tu ne vas que de 6 à 100
suppression de cellule trouvée
et
suppression de col
tu cherches "$cahier" dans la colonne B donc Col sera toujours égale à "B" (ou 2)
je n'ai pas regardé les imbrications avec i et j peut ^tre avant ou après le next.. à toi de voir
Workbooks.Open (CheminFichier & Fichier)
indice = "$cahier"
Set Plage = Sheets(1).Range("B16:B100") 'sheets non précisé à adapter
nbre = Application.CountIf(Plage, indice)
If nbre = 0 Then
ligne = 15
For Cptr = 1 To nbre
ligne = Plage.Find(indice, Cells(ligne, "B"), lookat:=xlWhole).Row
With Workbooks("Programme.xlsm").Sheets("Inv")
.Cells(j, (l + 1)).Value = Cells((ligne - 1), "C")
'... etc
End With
Next
End If
Else
'msgbox.....
Michel-
Bonjour,
merci pour votre réponse.
Cependant, ce code ne fonctionne pas.
Ai-je peut-être fais une erreur ?
Sub recherche()
Dim i As Long
Dim j As Long
Dim l As Long
Dim req As String
Dim Fichier As String
Dim CheminFichier As String
Dim indice As String
Dim ligne As Long
Dim Plage As Range
Dim repere As Byte
CheminFichier = "C: ..."
re:
req = InputBox("Renseignez un nom")
If req = "" Then
MsgBox "Vous n'avez rien saisie"
GoTo re
End If
If req <> "" Then
Application.ScreenUpdating = False
i = 2
j = 2
l = 1
Do While Sheets("donnees").Cells(i, 2).Value <> ""
If req = Sheets("donnees").Cells(i, 2).Value Then
Fichier = Sheets("donnees").Cells(i, 1).Value
Workbooks.Open (CheminFichier & Fichier)
indice = "$cahier"
Set Plage = Sheets(1).Range("B16:B100")
nbre = Application.CountIf(Plage, indice)
If nbre = 0 Then
repere = 15
For Cptr = 1 To nbre
repere = Plage.Find(indice, Cells(Ligne, "B"), lookat:=xlWhole).Row
With Workbooks("Programme.xlsm").Sheets("Inv")
.Cells(j, (l + 1)).Value = Cells((Ligne - 1), "C")
.Cells(j, l).Value = Cells((Ligne - 1), "B")
.Cells(j, (l + 2)).Value = Cells((Ligne - 1), "D")
.Cells(j, (l + 3)).Value = Cells((Ligne - 1), "E")
End With
Next
Workbooks("Programme.xlsm").Sheets("Inv").Cells(j, 5).Value = Workbooks("Programmexlsm").Sheets("donnees").Cells(i, 1).Value
End If
Workbooks(Fichier).Close (True)
end if
i = i + 1
loop
end if
end sub
-
-
bonjour,
je n'ai plus le pb en t^te mais j'ai du écrire une C... (au choix)
if nbre>0 au lieu de nbre=0
-
-
BONJOUR,
Je n'ai pas que ca à faire !
le mieux est de joindre les 2 classeurs dans un zip
Mettre le zip sans données confidentielles en pièce jointe sur https://www.cjoint.com/
et coller le raccourci par un clic droit sur le lien proposé dans le message de réponse
