XL 2010 RESOLU / Menu en cascade et recherche multi texte dans cellules avec correspondances dans un tableau

R

richard31

XLDnaute Occasionnel
Bonjour les experts !
Voilà mon souci :
J'ai un tableau source dans lequel si vous allez dans l'onglet "Données Générales" dans la colonne K "Périmètre technique" en k17 on peut à l'aide d'un VB aller sélectionner des entrées présentes dans un autre onglet nommé "Contacts-Et-Annuaire" colonne A (de A6 à A28) en cochant les sélections désirées. Ce vb fonctionne correctement alors que j'y pompe pas grand chose mais j'ai réussit à l'adapter, seul message d'erreur c'est quand on sélectionne aucune option ( j'arrive pas à gérer cette erreur).
Ce que je n'arrive pas à faire, c'est ensuite, donc dans la colonne K on a sélectionné les entrées avec le vb, ces valeurs s'écrivent dans la cellule correspondante, la tout fonctionne (sauf la si on sélectionne rien bref..). Colonne L nommée "Directions Impactées source" je désire suivant les sélections effectuée en colonne K aller chercher les correspondances dans l'onglet "Contacts-Et-Annuaire" colonne B nommée "direction". En gros un exemple :
Colonne K17 j'ai sélectionné "Base de données et AGL Dev Qualif et Base de données Pre-Expo et Production" le deux sont séparés par un | , Base de données et AGL Dev Qualif dans l'onglet "Contacts-Et-Annuaire" du tableau est présent dans la colonne A et en B (Direction) on retrouve " ABC " . Comment récupérer ABC et l'écrire dans l'onglet "Données Générales" en L17 ? Ainsi que pour "Base de données Pre-Expo et Production" auquel correspond JKI dans "Contacts-Et-Annuaire"? et le tout écrit dans une même cellule en L17 séparé par des / ? J'ai trouvé des formules qui fonctionnent mais le souci est que par exemple "Base de données" est répété dans le tableau "Contacts-Et-Annuaire" du coup ça va le lire plusieurs fois .

Bref j'ai enregistré le fichier . Le VB qui permet de créer un menu en cascade et lire des données d'une colonne est pas mal malgré le petit bug si on ne sélectionne rien ça peut servir à d'autres. Par contre le reste je n 'y arrive pas pour lire plusieurs entrées dans un cellule faire une recherche dans un tableau et noter les correspondances dans un autre cellule. C'est trop chaud pour moi !

merci d'avance milles fois pour les experts Excel ^^

Ps il y aussi un fonction VB "sans doublon" qui permet de lire et copier plusieurs données textes écrites dans une cellule sans les doublons. C'est cadeau aussi !4

Données anonymisée bien sur !
 

Pièces jointes

  • TEST.xlsm
    949.7 KB · Affichages: 16
Trier par date Trier par votes
R

richard31

XLDnaute Occasionnel
Rouge à dit:
Bonjour,

Ou celle-ci
Cliquez pour agrandir...
Bonjour
Super ton code ! et merci ^^ Es ce possible de récupérer la lite des directions sans doublons ? Je suis obligé de passer par ce code ci-dessous qui du coup ne fonctionne plus je pense que c'est du au split et l'affichage que ti as généré pour les directions :(

Function SansDoublonsCellule(c)
Set mondico = CreateObject("Scripting.Dictionary")
tbl = Split(c, " ")
For Each i In tbl
If Not mondico.Exists(Trim(i)) Then mondico.Add Trim(i), Trim(i)
Next i
temp = ""
For Each E In mondico.items
temp = temp & E & " / "
Next
SansDoublonsCellule = Left(temp, Len(temp) - 2)
End Function
 

Pièces jointes

  • richard31_Menu en cascade et recherche multi texte dans cellules avec correspondances dans un...xlsm
    916.9 KB · Affichages: 15
Vote positif 0 Vote négatif
R

Rouge

XLDnaute Impliqué
Bonjour,

Bizarre, voici l'essai en vidéo, tout semble fonctionner normalement
richard31.gif
 
Vote positif 0 Vote négatif
R

Rouge

XLDnaute Impliqué
Je crois que je viens de comprendre, en fait j'avais fait en sorte que les périmètres techniques soient disposés individuellement en ligne et qu'en face s'affichent les directions, donc 2 périmètres différents peuvent avoir la même direction.
Si j'avais pris cette option, c'est que cela me semblait plus logique pour la lecture alors que, si tout est en ligne et séparé par des "/", on ne pouvait pas faire l'association "périmètre/direction".
C'est une question de point de vue. maintenant si la présentation en lignes séparées vous convient toujours mais que vous ne vouliez pas de doublons dans les directions, alors OK, je regarde ça.
 
Vote positif 0 Vote négatif
R

richard31

XLDnaute Occasionnel
Rouge à dit:
Je crois que je viens de comprendre, en fait j'avais fait en sorte que les périmètres techniques soient disposés individuellement en ligne et qu'en face s'affichent les directions, donc 2 périmètres différents peuvent avoir la même direction.
Si j'avais pris cette option, c'est que cela me semblait plus logique pour la lecture alors que, si tout est en ligne et séparé par des "/", on ne pouvait pas faire l'association "périmètre/direction".
C'est une question de point de vue. maintenant si la présentation en lignes séparées vous convient toujours mais que vous ne vouliez pas de doublons dans les directions, alors OK, je regar
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif
R

Rouge

XLDnaute Impliqué
Dans votre fonction, le séparateur n'est pas un espace mais un renvoi à la ligne CAR(10)
Votre code corrigé

VB: 
Function SansDoublonsCellule(c)
    Set mondico = CreateObject("Scripting.Dictionary")
    tbl = Split(c, Chr(10))
    For Each i In tbl
        If Not mondico.Exists(Trim(i)) Then mondico.Add Trim(i), Trim(i)
    Next i
    temp = " "
    For Each E In mondico.items
        temp = temp & E & " / "
    Next
    SansDoublonsCellule = Left(temp, Len(temp) - 2)
End Function

Cdlt
 
Vote positif 0 Vote négatif
R

richard31

XLDnaute Occasionnel
Rouge à dit:
Dans votre fonction, le séparateur n'est pas un espace mais un renvoi à la ligne CAR(10)
Votre code corrigé

VB: 
Function SansDoublonsCellule(c)
    Set mondico = CreateObject("Scripting.Dictionary")
    tbl = Split(c, Chr(10))
    For Each i In tbl
        If Not mondico.Exists(Trim(i)) Then mondico.Add Trim(i), Trim(i)
    Next i
    temp = " "
    For Each E In mondico.items
        temp = temp & E & " / "
    Next
    SansDoublonsCellule = Left(temp, Len(temp) - 2)
End Function

Cdlt
Cliquez pour agrandir...
Super je me doutais que c'était là le problème, mais je connais peu le VB
Encore milles fois merci pour votre aide car du coup tout est ok pour moi !
Heureusement qu'il y a des gens comme vous ^^
 
Vote positif 0 Vote négatif
R

richard31

XLDnaute Occasionnel
Rouge à dit:
Dans votre fonction, le séparateur n'est pas un espace mais un renvoi à la ligne CAR(10)
Votre code corrigé

VB: 
Function SansDoublonsCellule(c)
    Set mondico = CreateObject("Scripting.Dictionary")
    tbl = Split(c, Chr(10))
    For Each i In tbl
        If Not mondico.Exists(Trim(i)) Then mondico.Add Trim(i), Trim(i)
    Next i
    temp = " "
    For Each E In mondico.items
        temp = temp & E & " / "
    Next
    SansDoublonsCellule = Left(temp, Len(temp) - 2)
End Function

Cdlt
Cliquez pour agrandir...
Re !
Je ne sais pas si je peux abuser de votre expertise :( En fait j'aurai juste une question... Si je veux un autre menu dans le même onglet mais par exemple deux colonnes avant comment on fait ? J'imagine qu'il faut initialiser une listbox 2 et lui indiquer que c'est la colonne If Target.Column = 9 Then mais je comprends pas comment l'adapter !


Option Explicit
Dim i As Long
Dim sTemp As String, sTemp1 As String
Dim a
Dim bTest As Boolean
Dim x As Range
Private Sub ListBox1_Change()
sTemp = ""
sTemp1 = ""
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) Then
sTemp = sTemp & Me.ListBox1.list(i) & Chr(10)
Set x = Worksheets("Contacts-Et-Annuaire").Range("A5:A28").Find(Me.ListBox1.list(i), lookat:=xlWhole)
If Not x Is Nothing Then
sTemp1 = sTemp1 & Chr(10) & Worksheets("Contacts-Et-Annuaire").Cells(x.Row, "B")
End If
End If
Next
If sTemp <> "" Then
sTemp = Left(sTemp, VBA.Len(sTemp) - 1)
ActiveCell = sTemp
ActiveCell.offset(0, 1).Value = Mid(sTemp1, 2, Len(sTemp) - 1)
End If
End Sub


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
If Target.Column = 11 Then
With Me.ListBox1
.MultiSelect = fmMultiSelectMulti
.ListStyle = fmListStyleOption
.Height = 100
.Width = 250
.Top = ActiveCell.Top
.Left = ActiveCell.offset(0, 1).Left
.Visible = True
End With
On Error Resume Next
i = 0
Me.ListBox1.list = Worksheets("Contacts-Et-Annuaire").Range(Worksheets("Contacts-Et-Annuaire").Range("A5:A28").offset(1, i), _
Worksheets("Contacts-Et-Annuaire").Range("A5:A28").offset(0, i).End(xlDown)).Value
On Error GoTo 0
a = VBA.Split(ActiveCell, Chr(10))
Else
Me.ListBox1.Visible = False
End If
Application.EnableEvents = True
End Sub

Désolé pour le dérangement si cela est compliqué à adapter...
 
Vote positif 0 Vote négatif
R

Rouge

XLDnaute Impliqué
Bonjour,
Si j'ai bien compris, vous voulez ajouter une listbox2 en colonne 9, alors ceci devrait aller, les modifs à apporter dans la macro sont en couleur

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
If Target.Column = 11 Then
With Me.ListBox1
.MultiSelect = fmMultiSelectMulti
.ListStyle = fmListStyleOption
.Height = 100
.Width = 250
.Top = ActiveCell.Top
.Left = ActiveCell.Offset(0, 1).Left
.Visible = True
End With
On Error Resume Next
i = 0
Me.ListBox1.List = Worksheets("Contacts-Et-Annuaire").Range(Worksheets("Contacts-Et-Annuaire").Range("A5:A28").Offset(1, i), _
Worksheets("Contacts-Et-Annuaire").Range("A5:A28").Offset(0, i).End(xlDown)).Value
On Error GoTo 0
a = VBA.Split(ActiveCell, Chr(10))
Me.ListBox2.Visible = False 'ici on masque la nouvelle listbox2
ElseIf Target.Column = 9 Then
'insérez ici ce que doit faire l'appli quand on sélectionne la colonne 9

Me.ListBox1.Visible = False 'ici on masque la listbox1
End If
Application.EnableEvents = True
End Sub

la macro à compléter par vos soins
VB: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Application.EnableEvents = False
    If Target.Column = 11 Then
        With Me.ListBox1
            .MultiSelect = fmMultiSelectMulti
            .ListStyle = fmListStyleOption
            .Height = 100
            .Width = 250
            .Top = ActiveCell.Top
            .Left = ActiveCell.Offset(0, 1).Left
            .Visible = True
        End With
        On Error Resume Next
        i = 0
        Me.ListBox1.List = Worksheets("Contacts-Et-Annuaire").Range(Worksheets("Contacts-Et-Annuaire").Range("A5:A28").Offset(1, i), _
        Worksheets("Contacts-Et-Annuaire").Range("A5:A28").Offset(0, i).End(xlDown)).Value
        On Error GoTo 0
        a = VBA.Split(ActiveCell, Chr(10))
        Me.ListBox2.Visible = False 'ici on masque la nouvelle listbox2
    ElseIf Target.Column = 9 Then
        'insérez ici ce que dit faire l'appli quand on sélectionne la colonne 9
        
        
        Me.ListBox1.Visible = False 'ici on masque la listbox1
    End If
    Application.EnableEvents = True
End Sub
Cdlt
 
Vote positif 0 Vote négatif
R

richard31

XLDnaute Occasionnel
Rouge à dit:
Bonjour,
Si j'ai bien compris, vous voulez ajouter une listbox2 en colonne 9, alors ceci devrait aller, les modifs à apporter dans la macro sont en couleur

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
If Target.Column = 11 Then
With Me.ListBox1
.MultiSelect = fmMultiSelectMulti
.ListStyle = fmListStyleOption
.Height = 100
.Width = 250
.Top = ActiveCell.Top
.Left = ActiveCell.Offset(0, 1).Left
.Visible = True
End With
On Error Resume Next
i = 0
Me.ListBox1.List = Worksheets("Contacts-Et-Annuaire").Range(Worksheets("Contacts-Et-Annuaire").Range("A5:A28").Offset(1, i), _
Worksheets("Contacts-Et-Annuaire").Range("A5:A28").Offset(0, i).End(xlDown)).Value
On Error GoTo 0
a = VBA.Split(ActiveCell, Chr(10))
Me.ListBox2.Visible = False 'ici on masque la nouvelle listbox2
ElseIf Target.Column = 9 Then
'insérez ici ce que doit faire l'appli quand on sélectionne la colonne 9

Me.ListBox1.Visible = False 'ici on masque la listbox1
End If
Application.EnableEvents = True
End Sub

la macro à compléter par vos soins
VB: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Application.EnableEvents = False
    If Target.Column = 11 Then
        With Me.ListBox1
            .MultiSelect = fmMultiSelectMulti
            .ListStyle = fmListStyleOption
            .Height = 100
            .Width = 250
            .Top = ActiveCell.Top
            .Left = ActiveCell.Offset(0, 1).Left
            .Visible = True
        End With
        On Error Resume Next
        i = 0
        Me.ListBox1.List = Worksheets("Contacts-Et-Annuaire").Range(Worksheets("Contacts-Et-Annuaire").Range("A5:A28").Offset(1, i), _
        Worksheets("Contacts-Et-Annuaire").Range("A5:A28").Offset(0, i).End(xlDown)).Value
        On Error GoTo 0
        a = VBA.Split(ActiveCell, Chr(10))
        Me.ListBox2.Visible = False 'ici on masque la nouvelle listbox2
    ElseIf Target.Column = 9 Then
        'insérez ici ce que dit faire l'appli quand on sélectionne la colonne 9
       
       
        Me.ListBox1.Visible = False 'ici on masque la listbox1
    End Ifin
    Application.EnableEvents = True
End Sub
Cdlt
Cliquez pour agrandir...
Put.. de bor... de ... Je n'y arrive pas !!!! je comprends que peu de choses en VB J'arrive à lui dire de le faire en colonne 9 et quoi prendre mais pas à le faire faire les deux colonnes !

ça c'est le code qui fonctionne :

Option Explicit
Dim i As Long
Dim sTemp As String, sTemp1 As String
Dim a
Dim bTest As Boolean
Dim x As Range
Private Sub ListBox1_Change()
sTemp = ""
sTemp1 = ""
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) Then
sTemp = sTemp & Me.ListBox1.list(i) & Chr(10)
Set x = Worksheets("Contacts-Et-Annuaire").Range("A5:A28").Find(Me.ListBox1.list(i), lookat:=xlWhole)
If Not x Is Nothing Then
sTemp1 = sTemp1 & Chr(10) & Worksheets("Contacts-Et-Annuaire").Cells(x.Row, "B")
End If
End If
Next
If sTemp <> "" Then
sTemp = Left(sTemp, VBA.Len(sTemp) - 1)
ActiveCell = sTemp
ActiveCell.offset(0, 1).Value = Mid(sTemp1, 2, Len(sTemp) - 1)
End If
End Sub


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
If Target.Column = 11 Then
With Me.ListBox1
.MultiSelect = fmMultiSelectMulti
.ListStyle = fmListStyleOption
.Height = 100
.Width = 250
.Top = ActiveCell.Top
.Left = ActiveCell.offset(0, 1).Left
.Visible = True
End With
On Error Resume Next
i = 0
Me.ListBox1.list = Worksheets("Contacts-Et-Annuaire").Range(Worksheets("Contacts-Et-Annuaire").Range("A5:A28").offset(1, i), _
Worksheets("Contacts-Et-Annuaire").Range("A5:A28").offset(0, i).End(xlDown)).Value
On Error GoTo 0
a = VBA.Split(ActiveCell, Chr(10))
Else
Me.ListBox1.Visible = False
End If
Application.EnableEvents = True
End Sub


Je comprends pas comme refaire la même chose pour la colonne 9 donc la 11 et la 9 ! Dingue je bugue
 
Vote positif 0 Vote négatif

Discussions similaires

R
  • Question
Microsoft 365 RESOLU Récupération plusieurs informations dans une cellule et remplir un autre tableau
2
Réponses
27
Affichages
802
Cousinhub
Cousinhub
B
  • Question
XL 2016 Recherchez des valeurs et copiez-les dans un autre tableau en fonction de certaines conditions
Réponses
4
Affichages
602
bossman_16
B
G
  • Question
Microsoft 365 Avoir des classeurs maitres et les procédures dans un autre classeur.
2
Réponses
18
Affichages
1 K
GClaire
G
R
  • Question
XL 2010 Recherche correspondances multi textes présents dans cellule sans doublons
Réponses
4
Affichages
1 K
gbinforme
G
O
  • Question
XL 2019 Je veux afficher mes données dans ma Listbox1 avec l'entete de ma Base donnée et fait la recherche sans que cela derange l'entete.
Réponses
6
Affichages
766
ChTi160
ChTi160
AugusteP
  • Question
XL 2021 Résultats dans un formulaire VBA suite à la saisie d'un texte contenu dans un tableau Excel
Réponses
10
Affichages
746
AugusteP
AugusteP
Nico2978
  • Résolu(e)
XL 2019 Aide pour un module d'archivage de feuille en pdf dans répertoire
Réponses
5
Affichages
532
Nico2978
Nico2978
E
  • Question
XL 2013 Recherche d'une valeur en fonction d'autres dans un tableau
Réponses
3
Affichages
682
eka
E
R
  • Question
Microsoft 365 RESOLU Conditions multiples avec dates et textes dans cellule
Réponses
2
Affichages
594
richard31
R
R
  • Question
Microsoft 365 RESOLU Utilisation Segments avec sélections multiples automatiques
Réponses
5
Affichages
2 K
richard31
R

Membres actuellement en ligne

Aucun membre en ligne actuellement.
1 membres et 36 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 079
Messages
2 115 983
Membres
112 632
dernier inscrit
mouad2025