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

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: 15

richard31

XLDnaute Occasionnel
Bonjour,

Ou celle-ci
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: 13

Rouge

XLDnaute Impliqué
Bonjour,

Bizarre, voici l'essai en vidéo, tout semble fonctionner normalement
richard31.gif
 

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.
 

richard31

XLDnaute Occasionnel
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
 

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
 

richard31

XLDnaute Occasionnel
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
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 ^^
 

richard31

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

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
 

richard31

XLDnaute Occasionnel
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
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
 

Discussions similaires