filtre avec critere dans une listbox

Version imprimable

bonsoir à vous.
je voudrais afficher dans ma listbox le choix fait dans le combobox. dans la base de donnée le filtre se fait aisement apres selection du critère mais je n'arrive pas à le transposer dans ma listbox. voir code

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
If T_fitre2.Text = "CP1" Then
 ActiveSheet.ListObjects("Tab_1").Range.AutoFilter Field:=4, Criteria1:= _
        "CP1"
ElseIf T_fitre2.Text = "CP2" Then
ActiveSheet.ListObjects("Tab_1").Range.AutoFilter Field:=4, Criteria1:= _
        "CP2"
        ElseIf T_fitre2.Text = "CE1" Then
ActiveSheet.ListObjects("Tab_1").Range.AutoFilter Field:=4, Criteria1:= _
        "CE1"
        ElseIf T_fitre2.Text = "CE2" Then
ActiveSheet.ListObjects("Tab_1").Range.AutoFilter Field:=4, Criteria1:= _
        "CE2"
        ElseIf T_fitre2.Text = "CM1" Then
ActiveSheet.ListObjects("Tab_1").Range.AutoFilter Field:=4, Criteria1:= _
        "CM1"
        ElseIf T_fitre2.Text = "CM2" Then
ActiveSheet.ListObjects("Tab_1").Range.AutoFilter Field:=4, Criteria1:= _
        "CM2"
 
End If

et j'alimente ma listbox avec

Code:

1
2
3
4
5
6
7
Dim f
Set f = Sheets("source")
Me.ListBox3.ColumnCount = f.Columns.Count
Me.ListBox3.BoundColumn = f.Columns.Count
Me.ListBox3.List = Range(f.[A1], f.[Z6500].End(xlUp)).Value
Me.ListBox3.Multiselect = fmMultiSelectMulti
ListBox3.ColumnWidths = "80;150;100;100;100;100;100;100;100;100;100;100;100;100;100;100;100;100;80;100;150;100;150;100;85;85;85;100"

quel code puis je ajouter au premier pour que le tableau qui est trié s'affiche dans la listbox .merci

Bonour,

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
Option Compare Text
Dim TBlBD()
Private Sub UserForm_Initialize()
  TBlBD = [tableau1].Value        ' pour rapidité
  Me.ListBox1.List = TBlBD
  Me.ListBox1.ColumnCount = [tableau1].Columns.Count
  Me.ListBox1.ColumnWidths = "30;50;50;50;50;50;50;50;50;50;50"
  '--- ComboBox
  Set d = CreateObject("scripting.dictionary")
  d("*") = ""
  For i = 1 To UBound(TBlBD)
    d(TBlBD(i, 4)) = ""
  Next i
  temp = d.keys
  Me.ComboBox1.List = temp
End Sub
 
Private Sub ComboBox1_click()
  ColRecherche = 4
  clé = Me.ComboBox1: n = 0
  Dim Tbl()
  For i = 1 To UBound(TBlBD)
    If TBlBD(i, ColRecherche) Like clé Then
        n = n + 1: ReDim Preserve Tbl(1 To UBound(TBlBD, 2), 1 To n)
        For k = 1 To UBound(TBlBD, 2): Tbl(k, n) = TBlBD(i, k): Next k
     End If
  Next i
  If n > 0 Then Me.ListBox1.Column = Tbl Else Me.ListBox1.Clear
End Sub

Boisgontier

Version avec choix classe par combobox & recherche intuitive sur le nom

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
Dim TBlBD(), Tbl()
Private Sub UserForm_Initialize()
  TBlBD = [tableau1].Value        ' pour rapidité
  Me.ListBox1.List = TBlBD
  Me.ListBox1.ColumnCount = [tableau1].Columns.Count
  Me.ListBox1.ColumnWidths = "30;50;50;50;50;50;50;50;50;50;50"
  '------------------------ Alimentation ComboBox
  Set d = CreateObject("scripting.dictionary")
  d("*") = ""
  For i = 1 To UBound(TBlBD)
    d(TBlBD(i, 4)) = ""
  Next i
  temp = d.keys
  Me.ComboBox1.List = temp
  Me.ComboBox1 = "*"
End Sub
 
Private Sub ComboBox1_click()
  NbLignes = Application.CountIf([Tableau1[Classe]], Me.ComboBox1)
  ColRecherche = 4
  clé = Me.ComboBox1: n = 0
  ReDim Tbl(1 To NbLignes, 1 To UBound(TBlBD, 2))
  For i = 1 To UBound(TBlBD)
    If TBlBD(i, ColRecherche) Like clé Then
        n = n + 1
        For k = 1 To UBound(TBlBD, 2): Tbl(n, k) = TBlBD(i, k): Next k
     End If
  Next i
  Me.TextBoxRech = ""
  If n > 0 Then Me.ListBox1.List = Tbl Else Me.ListBox1.Clear
End Sub
 
Private Sub TextBoxRech_Change()
  Dim b()
  If Me.TextBoxRech <> "" Then
   Set d1 = CreateObject("Scripting.Dictionary")
   tmp = Me.TextBoxRech & "*"
   n = 0
   For i = 1 To UBound(Tbl)
      If Tbl(i, 2) Like tmp Then
        n = n + 1: ReDim Preserve b(1 To UBound(Tbl, 2), 1 To n)
        For k = 1 To UBound(Tbl, 2): b(k, n) = Tbl(i, k): Next k
     End If
   Next i
   If n > 0 Then Me.ListBox1.Column = b Else Me.ListBox1.Clear
 Else
   Me.ListBox1.List = Tbl
 End If
End Sub

Boisgontier

Citation:

Envoyé par boisgontierjacques

Version avec choix classe par combobox & recherche intuitive sur le nom

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
Dim TBlBD(), Tbl()
Private Sub UserForm_Initialize()
  TBlBD = [tableau1].Value        ' pour rapidité
  Me.ListBox1.List = TBlBD
  Me.ListBox1.ColumnCount = [tableau1].Columns.Count
  Me.ListBox1.ColumnWidths = "30;50;50;50;50;50;50;50;50;50;50"
  '------------------------ Alimentation ComboBox
  Set d = CreateObject("scripting.dictionary")
  d("*") = ""
  For i = 1 To UBound(TBlBD)
    d(TBlBD(i, 4)) = ""
  Next i
  temp = d.keys
  Me.ComboBox1.List = temp
  Me.ComboBox1 = "*"
End Sub
 
Private Sub ComboBox1_click()
  NbLignes = Application.CountIf([Tableau1[Classe]], Me.ComboBox1)
  ColRecherche = 4
  clé = Me.ComboBox1: n = 0
  ReDim Tbl(1 To NbLignes, 1 To UBound(TBlBD, 2))
  For i = 1 To UBound(TBlBD)
    If TBlBD(i, ColRecherche) Like clé Then
        n = n + 1
        For k = 1 To UBound(TBlBD, 2): Tbl(n, k) = TBlBD(i, k): Next k
     End If
  Next i
  Me.TextBoxRech = ""
  If n > 0 Then Me.ListBox1.List = Tbl Else Me.ListBox1.Clear
End Sub
 
Private Sub TextBoxRech_Change()
  Dim b()
  If Me.TextBoxRech <> "" Then
   Set d1 = CreateObject("Scripting.Dictionary")
   tmp = Me.TextBoxRech & "*"
   n = 0
   For i = 1 To UBound(Tbl)
      If Tbl(i, 2) Like tmp Then
        n = n + 1: ReDim Preserve b(1 To UBound(Tbl, 2), 1 To n)
        For k = 1 To UBound(Tbl, 2): b(k, n) = Tbl(i, k): Next k
     End If
   Next i
   If n > 0 Then Me.ListBox1.Column = b Else Me.ListBox1.Clear
 Else
   Me.ListBox1.List = Tbl
 End If
End Sub

Boisgontier

le premier code que vous m'avez envoyé fonctionne à merveille. je vais néammoins noter le deuxieme aussi car je dois absolument comprendre les indices que vous utiliser exemple les k, m,a car ça me donnent le vertige:mrgreen::mrgreen:.
merci et merci car vous etes beaucoup disponible quand je poste. j'espere etre à un niveau appréciable et aider les autres aussi. merci

01/09/2018, 08h44
Mr l'Ashanti

parfait. le deuxieme code que vous m'avez fournit c'est ce que je recherchais pour mon formulaire deuxieme page. si à une reception et l'on demande les refernces de l' élève facile d'abord de saisir sa classe et après le nom.
merci ;););)

1 pièce(s) jointe(s)

bonjour boisgontier. j'espere une bonne forme pour vous ce matin(heure locale).
voici le code que m'a fourni un modérateur de ce forum avec un peu de modification
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 Dim i As Integer If ComboBox1 <> "" Then For i = 0 To ListBox3.ListCount - 1 If ListBox3.Selected(i) = True Then Cells(i + 1, 20).Value = ComboBox1.Value ListBox3.Column(1, i) = ComboBox1.Value End If Next i Application.ScreenUpdating = True End If
je sais que vous ne travaillez pas sur pgm déja établi.
avec le code que vous m'avez donné lorsque j'attribue une décision à un élève ou à plusieurs élèves simultanément la correction à tendance à monter dans la base de donnée, (ligne-1 au lieu de ligne )au lieu de rester sur la ligne comme au début avant que je n'utilise votre code. aussi dans la listbox lors de la correction on peut voir la modif dans la colonne des noms alors que dans la base c'est dans la colonne 20. je note que la modif se fait dans la colonne 20.
en y ajoutant un autre problème (tout en signalant que le code fournit marche correctement donc pas de changement sur votre code) concernant le tri ascendant. cela ne mache plus. j'ai utilisé l'enregistrement de macro pour l'avoir mais avec le nouveau code il y a incompatibilté.
je vous envoie le projet retourché( les erreurs sont à la page 3 et 4du formulaire)

01/09/2018, 11h30
Mr l'Ashanti

tout es réglé.merci
mon projet est terminé.
je tiens à remercier tous ceux qui m'ont aidé de près comme de loin en particulier boisgontier, patricktoulon, sogedic , dysorthographie et aussi aux différents postes des uns et des autres.
a bientot pour un nouveau projet. d'ici là clin d'oeil;);););)
11/09/2018, 20h22
Mr l'Ashanti

1 pièce(s) jointe(s)

bonsoir ami boisgonthier.j'espere la grande forme chez vous

je continue d'utiliser votre code sur la recherche intuitive.
mais aujourd'hui il refuse de s'adapter. j'aimerais que vous expliquiez le dysfonctionnement malgré qu'il n' y a pas de débogage
merci