USF avec Listbox paramétrées

Version imprimable

22/07/2013, 16h25
jipeh

1 pièce(s) jointe(s)

USF avec Listbox paramétrées

Bonjour à tous,

En m'aidant des deux sujets ci dessous :
La

Et la

J'ai cherché à construire un USF me permettant de faire une recherche multi onglet.

Le fonctionnement est la suivant :
- On choisit un mapping en 1
- On choisit un code à chercher en 2
- On clique sur Results
- On a les valeurs en sorties en 4

Les mappings sont toujours de la forme Code + Libellé.
Tous les mappings en entrée vont vers le même mapping en sortie.

Ce que je souhaite faire, c'est implémenter une textbox me permettant de faire une recherche via une partie du libellé <= ca j'y arrive (txtbox 6 et listbox 2) mais surtout de lier les resultats de cette recherche au code.

Actuellement je peux faire la recherche avec une chaine de caractère sur le libellé et sur le code. Le fait de le faire sur le code ne m'interesse pas énormément, cependant est ce une piste interessante pour faire la liaison ?

En résumé, il me faut lier la liste de code (listbox3) à la liste des libellés (listbox2) qui est fonction du choix de mapping en 1.

De plus, si je peux éliminer les doublons de mes listes....

Un GRAND merci d'avance ! et n'hésitez pas si je ne suis pas clair...

Fichier joint !
22/07/2013, 16h47
Daniel.C

Bonjour,

Est-ce que tu peux donner un exemple de ce que tu souhaites ?
22/07/2013, 16h59
jipeh

Oui je peux :)

Donc je veux chercher dans le mapping MNO;
le code et le libellé correspondant à Léa.

Je sélectionne donc MNO en 1,
Je ne connais plus le code qui correspond a Lea donc je vais sur le deuxieme Textbox (en face de 2) et je tape le.

A ce moment là, j'ai trois résultats :
LEA
Leopoldine
LEA

Deja si la je pouvais supprimer les doublons ca serait cool :)

Je souhaite que la Listbox du code se mettes à jour pour ne conserver que les codes correspondants aux libellés présent dans la listbox des libellés.

Si quand je sélectionne d'un coté ça sélectionne de l'autre ca serait un rêve !

En choisissant LEA, je sais que le code correspondant au prénom est 011223.
Toutefois si je ne m'en rappele pas il faudrait que quand je sélectionne une valeur dans la liste des libellés, la sélection du code correspondant se fase automatiquement.

Ensuite je lance ma recherche par le bouton 3- Results. Lui il utilise le code pour faire la recherche.
En sortie, j'ai le code et le libellé correspondant dans le mapping MNO.
Soit :
- 45422 pierre
et
- 8958 toto

En fait je veux lier les deux listes, tout en concervant la possibilité de rechercher par code ou par texte.

Suis-je plus clair ?

Ca a l'air un peu plus compliqué que je ne le pensais. Tu devrais dissocier les recherches soit par texte, soit par code avec un seul listbox et un bouton de choix (texte ou code) Je te mets juste le code de la macro "Remplir pour éviter les doublons :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Private Sub Remplir()
Dim q As Range
Dim Stro As String
Dim s As Range
Dim Strs As String
Dim Dico As Object
 
Set Dico = CreateObject("Scripting.Dictionary")
Me.ListBox2.Clear
Stro = Me.TextBox6.Value
Stro = "*" & Replace(UCase(Stro), " ", "*") & "*"
Me.ListBox3.Clear
Strs = Me.TextBox1.Value
Strs = "*" & Replace(UCase(Strs), " ", "*") & "*"
For Each q In Sheets(Me.ListBox1.Value).Range("B3:B" & LastLig)
        If q.Value <> "" Then
            If UCase(q.Value) Like Stro Then
                If Not Dico.exists(q.Value) Then
                    Dico.Add q.Value, q.Value
                    Me.ListBox2.AddItem q.Value
                    Me.ListBox3.AddItem q.Offset(, -1).Value
                End If
            End If
        End If
Next q
 
'F s
End Sub

22/07/2013, 18h31
casefayere

Un petit fichier exemple que tu devrais pouvoir adapter
22/07/2013, 18h34
jipeh

1 pièce(s) jointe(s)

Deja nickel ton code pour les doublons ! Merci beaucoup.

Je vais changer mon fusil d'épaule alors pour ma recherche. J'ai modifié mon USF pour enlever la liste des codes et faire soit un choix si on connait le code, soit on chercher par le libellé.

Le fichier est joint.

Mon seul soucis étant, Quand je sélectionne mion libellé il faut que mon code correspondant se mette dans le textbox de recherche par code. C'est lui qui est utilisé par le bouton de résultat mais c'est aussi une bonne indication.

J'ai mis un stop dans le code pour montrer l'endroit ou je tombe.
22/07/2013, 18h36
jipeh

Citation:

Envoyé par casefayere

Un petit fichier exemple que tu devrais pouvoir adapter

Ha mince, j'ai répondu trop vite, je vais regarder ton fichier. Merci !
22/07/2013, 19h02
mercatog

Bonjour
Utilise plutôt des listbox multi-colonnes mieux que ta conception actuelle (les noms et codes seront attaché sur la même ligne de la listbox)
22/07/2013, 19h14
jipeh

Oh pas mal les listbox multicolonnes, je retiens pour un futur projet ! :)

Pour celui ci je vais me limiter à l'une ou l'autre des recherches.
Avoir une liste de code ne semble pas une super plus value au final, pcq soit on le connait soit on n'en sait rien...

Faut juste que je trouve comment répercuter le code quand je choisi le libellé. Une idée ? Deja est-ce le bon endroit où j'ai positionné mon stop ?

J'insiste sur la multi-colonne (avec 1ère colonne Code et seconde libellé). Son utilisation future est aisée.

Regarde ce code, que ce soit par code ou par libellé, ListBox2 est filtrée en conséquence

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
Option Explicit
 
Dim LastLig As Long
 
Private Sub UserForm_Initialize()
Dim Ws As Worksheet
 
For Each Ws In Worksheets
    If Len(Ws.Name) = 3 Then Me.ListBox1.AddItem Ws.Name
Next Ws
 
With Me.ListBox2
    .ColumnCount = 2
    .BoundColumn = 1
    .ColumnWidths = "70;150"
End With
End Sub
 
Private Sub Listbox1_Change()
 
Me.TextBox1.Value = ""
Me.TextBox6.Value = ""
Me.ListBox2.Clear
If Me.ListBox1.ListIndex > -1 Then
    With Sheets(Me.ListBox1.Value)
        LastLig = .Cells(.Rows.Count, 4).End(xlUp).Row
    End With
    Call Remplir
End If
End Sub
 
Private Sub Remplir(Optional ByVal Str As String, Optional ByVal Code As Boolean)
Dim Dico As Object
Dim Ofs As Byte
Dim c As Range
 
Me.ListBox2.Clear
Str = "*" & Replace(UCase(Str), " ", "*") & "*"
Ofs = Abs(Code)
Set Dico = CreateObject("Scripting.Dictionary")
For Each c In Worksheets(Me.ListBox1.Value).Range("A3:A" & LastLig).Offset(0, Ofs)
    If c.Value <> "" Then
        If UCase(c.Value) Like Str Then
            If Not Dico.exists(c.Value) Then
                Dico.Add c.Value, c.Value
                With Me.ListBox2
                    .AddItem c.Offset(0, -Ofs).Value
                    .List(.ListCount - 1, 1) = c.Offset(0, 1 - Ofs).Value
                End With
            End If
        End If
    End If
Next c
Set Dico = Nothing
End Sub
 
Private Sub TextBox1_Change()
 
Remplir Me.TextBox1.Value
End Sub
 
Private Sub TextBox6_Change()
 
Remplir Me.TextBox6.Value, True
End Sub

PS1. Renomme tes contrôles par des noms significatifs au lieu de ListBox1, TextBox6...

PS2. Il va rester une petite amélioration au cas ou un filtrage simultané par Code et par libellé.

PS3. Une bonne conception vaut mieux que des usines à gaz.

Ma proposition, j'ai renommé les contrôles convenablement. J'ai ensuite supprimé les contrôles non utiles.
Code en entier de l'Userform

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
Option Explicit
 
Dim LastLig As Long
 
Private Sub UserForm_Initialize()
Dim Ws As Worksheet
 
For Each Ws In Worksheets
    If Len(Ws.Name) = 3 Then Me.LstMap.AddItem Ws.Name
Next Ws
 
With Me.LstFiltre
    .ColumnCount = 2
    .BoundColumn = 1
    .ColumnWidths = "70;150"
End With
 
With Me.LstResult
    .ColumnCount = 2
    .BoundColumn = 1
    .ColumnWidths = "70;150"
End With
End Sub
 
Private Sub LstMap_Change()
 
Me.TbCode.Value = ""
Me.TbLibel.Value = ""
Me.LstFiltre.Clear
If Me.LstMap.ListIndex > -1 Then
    With Sheets(Me.LstMap.Value)
        LastLig = .Cells(.Rows.Count, 4).End(xlUp).Row
    End With
    Call Remplir
End If
End Sub
 
Private Sub Remplir(Optional ByVal Str As String, Optional ByVal Code As Boolean)
Dim Dico As Object
Dim Ofs As Byte
Dim c As Range
 
Me.LstFiltre.Clear
Str = "*" & Replace(UCase(Str), " ", "*") & "*"
Ofs = Abs(Code)
Set Dico = CreateObject("Scripting.Dictionary")
For Each c In Worksheets(Me.LstMap.Value).Range("A3:A" & LastLig).Offset(0, Ofs)
    If c.Value <> "" Then
        If UCase(c.Value) Like Str Then
            If Not Dico.exists(c.Value) Then
                Dico.Add c.Value, c.Value
                With Me.LstFiltre
                    .AddItem c.Offset(0, -Ofs).Value
                    .List(.ListCount - 1, 1) = c.Offset(0, 1 - Ofs).Value
                End With
            End If
        End If
    End If
Next c
Set Dico = Nothing
End Sub
 
Private Sub TbCode_Change()
 
Remplir Me.TbCode.Value
End Sub
 
Private Sub TbLibel_Change()
 
Remplir Me.TbLibel.Value, True
End Sub
 
Private Sub LstFiltre_Change()
Dim Code As String
Dim c As Range
 
Me.LstResult.Clear
If Me.LstFiltre.ListIndex > -1 Then
    Code = Me.LstFiltre.Value
    For Each c In Worksheets(Me.LstMap.Value).Range("A3:A" & LastLig)
        If c.Value = Code Then
            With Me.LstResult
                .AddItem c.Offset(0, 2).Value
                .List(.ListCount - 1, 1) = c.Offset(0, 3).Value
            End With
        End If
    Next c
End If
End Sub
 
Private Sub BtnReset_Click()
 
Me.LstMap.ListIndex = -1
End Sub
 
Private Sub BtnExit_Click()
 
Unload Me
End Sub

Fichier d'illustration

Bon, tu m'as convaincu ! Ton travail est super au niveau optimisation du code, je suis bluffé !

En regardant plus attentivement, j'ai essayé hier soir de mettre en place la possibilité de copier coller le résultat. Ne trouvant pas dans les propriétés, j'ai choisi d'implenter ca :
Code:

1 2 3 4 5 6 7 8 9 10 Private Sub lot_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) Dim NumCopie As String If KeyAscii = 3 Then NumCopie = lot.List(lot.ListIndex) With New DataObject .SetText NumCopie .PutInClipboard End With End If End Sub
J'ai bien la Bibliothèque MicroSoft Forms 2.0 Object Library. Toutefois ca ne semble pas fonctionner. Une idée ?

De plus, dans la liste des résultats, ces derniers apparaissaient préalablement sans doublons. Toutefois je n'ai toujours pas compris la technique du
Code:

1 2 3 4 5 6 7 8 9 10 11 Prem = c.Address Do Label = c.Offset(, F).Value Tmp = c.Offset(, E - F).Value If InStr(Str2, Tmp) = 0 Then Str2 = Str2 & vbNewLine & Tmp Tmp = c.Offset(, E - F + 1).Value If InStr(Str3, Tmp) = 0 Then Str3 = Str3 & vbNewLine & Tmp Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address <> Prem Str2 = Mid(Str2, 2) Str3 = Mid(Str3, 2)
qui était préalablement implenté.

Dans tous les cas, dors et déjà un grand merci !

23/07/2013, 12h01
mercatog

Bonjour
Nouvelle demande - nouveau sujet avec explication claire et détaillée du problème.
Là, on ne te suit pas.

Citation:

Envoyé par mercatog

Bonjour
Nouvelle demande - nouveau sujet avec explication claire et détaillée du problème.
Là, on ne te suit pas.

Done :)

Pour les doublons j'ai fait ca comme ceci :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Private Sub SupDoubles()
 
     Dim iPos As Integer
     iPos = 0
     'Si la listbox est vide il quitte la fonction
     If LstResult.ListCount < 1 Then Exit Sub
 
     Do While iPos < LstResult.ListCount
     LstResult.Text = LstResult.List(iPos)
     'Verifie si le text existe deja
 
     If LstResult.ListIndex <> iPos Then
     'Si c'est le cas il supprime et garde la position iPos...
     LstResult.RemoveItem iPos
     Else
     'Si ce n'est pas le cas il change la position iPos...
     iPos = iPos + 1
     End If
     Loop
 
End Sub

23/07/2013, 13h20
mercatog

As-tu des doublons dans LstResult?

Si c'est le cas, utilise un Dictionnaire comme pour LstFiltre.

Non?

Pour remplir ensuite supprimer?

PS. Si tu n'arrives pas, on peux te guider mais regarde le fonctionnement de la Sub Remplir.