Liste déroulante + recherchev en macro

[liquoreux]

Recherchev en macro

Bonjour,

Dans une précédente discussion j'avais obtenu le code suivant
https://www.excel-downloads.com/threads/recherchev-macro-cellule-non-vide.130247/

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lig As Long, txt$
On Error Resume Next
If Application.Trim(Cells(1, Target.Column)) <> "BUREAU DISTRIBUTEUR" Then Exit Sub
lig = Application.Match(Target, Sheets("CODEPOSTAUX").Columns(2), 0)
txt = Sheets("CODEPOSTAUX").Cells(lig, 1)
Cells(Target.Row, Application.Match("*CODE POSTAL*", Rows(1), 0)) = txt
End Sub

Je souhaiterais l'adapter au classeur en pièce jointe sur plusieurs colonnes :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lig As Long, txt$
On Error Resume Next
If Application.Trim(Cells(1, Target.Column)) <> "Activité_ayant_causé_l_accident" Then Exit Sub
lig = Application.Match(Target, Sheets("BASES").Columns(2), 0)
txt = Sheets("BASES").Cells(lig, 1)
Cells(Target.Row, Application.Match("CODE_Activité", Rows(1), 0)) = txt
End Sub

Colonnes concernées :
- CODE_Lieu
- CODE_Circonstances
- CODE_Elément
- CODE_Activité
- CODE_Siège des lésions
- CODE_Nature_Lésions

La recherche s'effectue dans les tableaux du feuillet "BASES", dans les colonnes contenant des lettres.

Exemple : si je saisi "Locaux techniques" dans la cellule A2 de la colonne intitulée "Lieu_précis_de_l_accident", la cellule B2 de la colonne "CODE_Lieu", indique le résultat : "A". Etc.

Le problème est que cela ne donne un résultat que sur une seule ligne, quelque soit la colonne.


Precisions : dans le tableau final, les colonnes n'auront pas les places indiquées dans le classeur joint pour l'exemple.

Merci pour votre aide🙂

 

[liquoreux]

Re : recherchev en macro

Macro complétée :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lig, lig1, lig2, lig3, lig4, lig5 As Long, txt$, txt1$, txt2$, txt3$, txt4$, txt5$

On Error Resume Next
If Application.Trim(Cells(1, Target.Column)) <> "Lieu_précis_de_l_accident" And Application.Trim(Cells(1, Target.Column)) <> "Circonstances" And Application.Trim(Cells(1, Target.Column)) <> "Elément_matériel" And Application.Trim(Cells(1, Target.Column)) <> "Activité_ayant_causé_l_accident" And Application.Trim(Cells(1, Target.Column)) <> "Siège_des_lésions" And Application.Trim(Cells(1, Target.Column)) <> "Nature_des_lésions" Then Exit Sub

lig = Application.Match(Target, Sheets("BASES").Columns(14), 0)
txt = Sheets("BASES").Cells(lig, 1)
Cells(Target.Row, Application.Match("CODE_Lieu", Rows(1), 0)) = txt

lig1 = Application.Match(Target, Sheets("BASES").Columns(17), 0)
txt1 = Sheets("BASES").Cells(lig1, 1)
Cells(Target.Row, Application.Match("CODE_Circonstances", Rows(1), 0)) = txt1

lig2 = Application.Match(Target, Sheets("BASES").Columns(5), 0)
txt2 = Sheets("BASES").Cells(lig2, 1)
Cells(Target.Row, Application.Match("CODE_Elément", Rows(1), 0)) = txt2

lig3 = Application.Match(Target, Sheets("BASES").Columns(2), 0)
txt3 = Sheets("BASES").Cells(lig3, 1)
Cells(Target.Row, Application.Match("CODE_Activité", Rows(1), 0)) = txt3

lig4 = Application.Match(Target, Sheets("BASES").Columns(11), 0)
txt4 = Sheets("BASES").Cells(lig4, 1)
Cells(Target.Row, Application.Match("CODE_Siège_des_lésions", Rows(1), 0)) = txt4

lig5 = Application.Match(Target, Sheets("BASES").Columns(8), 0)
txt5 = Sheets("BASES").Cells(lig5, 1)
Cells(Target.Row, Application.Match("CODE_Nature_Lésions", Rows(1), 0)) = txt5

End Sub

Problème : la macro ne met qu'un résultat par ligne quelque soit la colonne.

Pouvez-vous m'aider?

Merci

 

[liquoreux]

Re : Liste déroulante + recherchev en macro

Help! 🙁 🙁

 

[liquoreux]

Recherchev en macro

Bonjour,

Personne ne veut m'aider?🙁 🙁 🙁

Autre macro pour le même résultat avec le même problème (sur une même ligne, le résultat de recherche est effacé par un autre résultat dans une autre colonne. Je ne peux pas avoir plusieurs résultats sur une même ligne. Comment faire pour maintenir tous les résultats)? Je tourne en rond!! HELP :

Pour l'instant, la macro fonctionne sur les quatre premières colonnes du tableau joint. Il suffit de double cliquer + entrée sur les cellules en bleue d'une même ligne de la 1ère puis de la 3ème colonne pour voir le problème.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim col1 As Range, col2 As Range, ref As Range, txt$
Dim col3 As Range, col4 As Range, ref1 As Range, txt1$
On Error Resume Next
Set col1 = Rows(1).Find("Lieu_précis_de_l_accident", LookIn:=xlFormulas, LookAt:=xlPart).Offset(1).Resize(Rows.Count - 1)
Set col2 = Rows(1).Find("CODE_Lieu").Offset(1).Resize(Rows.Count - 1)
Set col3 = Rows(1).Find("Circonstances", LookIn:=xlFormulas, LookAt:=xlPart).Offset(1).Resize(Rows.Count - 1)
Set col4 = Rows(1).Find("CODE_Circonstances").Offset(1).Resize(Rows.Count - 1)
If Intersect(Target, Union(col1, col2)) Is Nothing And Intersect(Target, Union(col3, col4)) Is Nothing Then Exit Sub
With Sheets("BASES")
Set ref = .Range("M:N").Find(Target, LookAt:=xlWhole)

If Intersect(Target, col1) Then
txt = .Cells(ref.Row, 13)
End If
End With
With Sheets("BASES")
Set ref1 = .Range("P:Q").Find(Target, LookAt:=xlWhole)
If Intersect(Target, col4) Then
txt1 = .Cells(ref1.Row, 16)
End If

End With
Application.EnableEvents = False
Cells(Target.Row, IIf(Intersect(Target, col2) Is Nothing, col2.Column, col1.Column)) = txt

Cells(Target.Row, IIf(Intersect(Target, col4) Is Nothing, col4.Column, col3.Column)) = txt1
Application.EnableEvents = True
End Sub