Trie d'une liste déroulante

Le 22/10/2017 à 10:53

Bonjour à tous,

J'aimerai pouvoir trier par ordre alphabétiques les informations d'une liste déroulante se trouvant dans une formulaire, dont le ceode se trouve ci-dessous.

Pourriez-vous à nouveau m'aider?

Merci par avance

Private Sub ComboBox2_Change() 'Charge recette
Dim Ligne&, i&, MyImage$, Chemin$
On Error GoTo Fin
  Nettoyage 'Lance le programme Nettoyage
  If Me.ComboBox2.ListIndex = -1 Then Exit Sub
  Ligne = Me.ComboBox2.Column(1)
  For i = 1 To 11
    Me.Controls("TextBox" & i) = Ws.Cells(Ligne, i + 2)
  Next i
Label2 = Textbox2

 'programmation pour l'affichage des images dans l'userform
Chemin = ThisWorkbook.Path & "\IMAGES\" 'ThisWorkbook.path ... renvoi le répertoire ou est stocké le classeur contenant ton code.

MyImage = ComboBox2 & ".jpg"
If existeFichier(MyImage, Chemin) Then
  Image1.Tag = Chemin & MyImage
  Image1.Picture = LoadPicture(Image1.Tag) 'Modifiez le CHEMIN par le chemin exacte où se trouve l'image  (Ex. :  f:\recettes\   )
 Else
  Image1.Tag = ""
  Image1.Picture = LoadPicture(Chemin & "INEXISTANTE.jpg")
End If
MyImage = Textbox2 & ".jpg"
If existeFichier(MyImage, Chemin) Then
  Image2.Tag = Chemin & MyImage
  Image2.Picture = LoadPicture(Image2.Tag) 'Modifiez le CHEMIN par le chemin exacte où se trouve l'image  (Ex. :  f:\recettes\   )
 Else
  Image2.Tag = ""
  Image2.Picture = LoadPicture(Chemin & "INEXISTANTE2.jpg")
End If
Fin:
End Sub
Sub Nettoyage()
Dim i As Integer
  For i = 1 To 11
    Me.Controls("TextBox" & i) = ""
  Next i
End Sub
Le 22/10/2017 à 11:14

Bonjour,

tu ne nous as pas mis le bon bout de code !

je suppose que ta liste déroulante est dans combobox2. Mets-nous le code de chargement de combobox2 ou mieux le fichier, tu devrais le savoir depuis le temps ...

Le 22/10/2017 à 14:29

oups pardon!! j'espère ne pas mettre trompé

Option Explicit
Dim Coef As Long
Dim ActionSpin As String
Dim ActionList As String

Dim Ws As Worksheet
Dim NbLignes As Integer
Private Sub CommandButton1_Click() 'Quitter
  Unload Me
End Sub

Private Sub CommandButton2_Click()
Sheets("COURSES").Activate
Unload Me
End Sub

Private Sub CommandButton3_Click() 'Nouvelle recette
Dim L&, i&, d As Object
If MsgBox("Etes-vous certain de vouloir INSERER cette nouvelle recette ?", vbYesNo, "Demande de confirmation") = vbYes Then
  With Ws 'RECETTES
    L = .Range("A65536").End(xlUp).Row + 1 'Permet de se positionner sur la dernière ligne de tableau NON VIDE

    .Range("A" & L).Value = ComboBox1 'Insère la donnée  dans la colonne A
    .Range("B" & L).Value = ComboBox2 'Insère la donnée  dans la colonne B
    'et à suivre....
    For i = 1 To 11
      .Cells(L, i + 2) = Controls("Textbox" & i)
    Next
    If [TYPE_PLATS].Find(ComboBox1) Is Nothing Then
      Feuil2.Cells(65536, 1).End(3)(2) = ComboBox1
      Feuil2.Activate
      [TYPE_PLATS].Sort [A1], xlAscending, , , , , , xlNo
      Ws.Activate
    End If
    If [VIN].Find(Textbox9) Is Nothing Then
      Feuil2.Cells(65536, 6).End(3)(2) = Textbox9
      Feuil2.Activate
      [VIN].Sort [F1], xlAscending, , , , , , xlNo
      Ws.Activate
    End If
  ComboBox1.List = [TYPE_PLATS].Value
  Textbox9.List = [VIN].Value
  MsgBox ("Nouvelle recette inséré. Encore un nouveau plaisir!") 'Vous informe que le présent contact est insérer dans votre tableau Excel.
  End With
End If
End Sub
Private Sub CommandButton4_Click() 'Modifier
Dim Ligne&, i&
If MsgBox("Etes-vous certain de vouloir modifier cette recette ?", vbYesNo, "Demande de confirmation") = vbYes Then

  If Me.ComboBox1.ListIndex = -1 Then Exit Sub
  Ligne = Me.ComboBox2.Column(1)
    For i = 1 To 11
      If Me.Controls("TextBox" & i).Visible = True Then
        Ws.Cells(Ligne, i + 2) = Me.Controls("TextBox" & i)
      End If
    Next i
  End If

End Sub

Private Sub CommandButton5_Click() 'Envoi feuille Impression
Dim Tablo, i&
  Sheets("IMPRESSION").Select
  [B16:B400].ClearContents
  [A2] = ComboBox1: [A3] = ComboBox2
  [A6] = Textbox2: [B6] = Textbox4
  [A8] = Textbox1: [B8] = Textbox5
  [A10] = Textbox3: [B10] = TextBox8
  [A12] = Textbox9: [B12] = TextBox11
  [A14] = TextBox10: [A16] = TextBox6
  Tablo = Split(TextBox7.Text, Chr(10))
  For i = LBound(Tablo) To UBound(Tablo)
    Cells(i + 16, 2) = Trim(Replace(Tablo(i), Chr(10), ""))
  Next i
  Rows("16:400").EntireRow.AutoFit
  Call InsImage(Image1.Tag, [A4], -1)
  Call InsImage(Image2.Tag, [B4], 0)
  [A1].Activate
  Unload Me
End Sub
Private Sub InsImage(Image$, Cel As Range, Zoom As Boolean)
  If Cel <> "" Then ActiveSheet.Shapes.Range(Array(Cel.Value)).Delete
  Cel.Activate
  Cel = Image
  Sheets("IMPRESSION").Pictures.Insert(Image).Select
  With Selection
  .Name = Image
    If Zoom Then
      .ShapeRange.LockAspectRatio = msoTrue
      .Height = Cel.Height * 0.9
      If .Width > Cel.Width * 0.9 Then
        .Width = Cel.Width * 0.9
      End If
    End If
    .Top = Cel.Top + ((Cel.Height - .Height) / 2)
    .Left = Cel.Left + ((Cel.Width - .Width) / 2)
  End With
End Sub
Private Sub CommandButton6_Click()
  Worksheets("RECETTES").Visible = True 'Rend visible l'onglet TEST
  Worksheets("RECETTES").Activate  'Active l'onglet RECETTES
  ActiveSheet.Unprotect ("1124") 'Enlève le mote de passe
  Unload Me 'Ferme le formulaire actif
End Sub

Private Sub Image1_Click()

End Sub

Private Sub SpinButton1_SpinUp()
  ActionSpin = "Plus"
  Reglage
End Sub
Private Sub SpinButton1_SpinDown()
  ActionSpin = "Moins"
  Reglage
End Sub
Private Sub Reglage()
  With Me
    Coef = .SpinButton1 - 100
    .Height = ((599 / 100) * Coef) + 599 'correspond à la Hauteur de l'userform
    .Width = ((993 / 100) * Coef) + 993 'correspond à la largeur de l'userform
    .Zoom = .SpinButton1
  End With
End Sub
'TITRE du formulaire avec % du zoom
'Facultatif
Private Sub SpinButton1_Change()
  'Remarque : l'action Change étant un événement en amont de SpinUp ou SpinDown
  Me.Caption = "    RECETTES D'ALISON          -          Zoom à : " & Me.SpinButton1 & " %"
End Sub '-------------------------------------

Private Sub Textbox2_Change()

End Sub

Private Sub Textbox4_Change()

End Sub

Private Sub UserForm_Initialize()
Dim j&, i&, o&, p&, k&, m&, n&, q&
'Ote la croix de l'userform - Code Option Explicit dans module MOT_DE_PASSE
OteCroix Me.Caption

Set Ws = Worksheets("RECETTES")
NbLignes = Ws.Range("A65536").End(xlUp).Row

With Me.ComboBox2
  .ColumnCount = 2
  .ColumnWidths = "-1;0"
End With

With Me.Textbox2
  For j = 2 To Ws.Range("d" & Rows.Count).End(xlUp).Row
    .AddItem Ws.Range("d" & j)
  Next j
End With

Feuil2.Activate
  [TYPE_PLATS].Sort [A1], xlAscending, , , , , , xlNo
  ComboBox1.List = [TYPE_PLATS].Value
  Textbox1.List = [NBRE_PERSONNES].Value
  Textbox2.List = [NIVEAU_DIFFICULTE].Value
  Textbox3.List = [COUT].Value
  Textbox4.List = [TEMPS].Value
  Textbox5.List = [TEMPS].Value
  [VIN].Sort [F1], xlAscending, , , , , , xlNo
  Textbox9.List = [VIN].Value
Ws.Activate
With Me.SpinButton1
  .Value = 100          'valeur de base du zoom en %
  .Min = 50    'Valeur mini du zoom en %
  .Max = 200   'Valeur maxi du zoom en %
End With
Reglage
End Sub
Private Sub ComboBox1_Change() 'Type de plat
Dim j As Long

  Nettoyage    'Lance le programme Nettoyage

  Me.ComboBox2.Clear   'Efface les données de la combobox2
  If Me.ComboBox1.ListIndex = -1 Then Exit Sub
  With Me.ComboBox2
    For j = 2 To NbLignes
      If Ws.Range("A" & j) = Me.ComboBox1 Then
        .AddItem Ws.Range("B" & j)
        .List(.ListCount - 1, 1) = j
      End If
    Next j
  End With

End Sub
Private Sub ComboBox2_Change() 'Charge recette
Dim Ligne&, i&, MyImage$, Chemin$
On Error GoTo Fin
  Nettoyage 'Lance le programme Nettoyage
  If Me.ComboBox2.ListIndex = -1 Then Exit Sub
  Ligne = Me.ComboBox2.Column(1)
  For i = 1 To 11
    Me.Controls("TextBox" & i) = Ws.Cells(Ligne, i + 2)
  Next i
Label2 = Textbox2

 'programmation pour l'affichage des images dans l'userform
Chemin = ThisWorkbook.Path & "\IMAGES\" 'ThisWorkbook.path ... renvoi le répertoire ou est stocké le classeur contenant ton code.

MyImage = ComboBox2 & ".jpg"
If existeFichier(MyImage, Chemin) Then
  Image1.Tag = Chemin & MyImage
  Image1.Picture = LoadPicture(Image1.Tag) 'Modifiez le CHEMIN par le chemin exacte où se trouve l'image  (Ex. :  f:\recettes\   )
 Else
  Image1.Tag = ""
  Image1.Picture = LoadPicture(Chemin & "INEXISTANTE.jpg")
End If
MyImage = Textbox2 & ".jpg"
If existeFichier(MyImage, Chemin) Then
  Image2.Tag = Chemin & MyImage
  Image2.Picture = LoadPicture(Image2.Tag) 'Modifiez le CHEMIN par le chemin exacte où se trouve l'image  (Ex. :  f:\recettes\   )
 Else
  Image2.Tag = ""
  Image2.Picture = LoadPicture(Chemin & "INEXISTANTE2.jpg")
End If
Fin:
End Sub
Sub Nettoyage()
Dim i As Integer
  For i = 1 To 11
    Me.Controls("TextBox" & i) = ""
  Next i
End Sub
Le 22/10/2017 à 14:58

bonjour,

à tester

Private Sub ComboBox1_Change()    'Type de plat
    Dim j As Long, k
    Dim a(0), b(0)
    Nettoyage    'Lance le programme Nettoyage
    k = 0
    Me.ComboBox2.Clear   'Efface les données de la combobox2
    If Me.ComboBox1.ListIndex = -1 Then Exit Sub
    With Me.ComboBox2
        For j = 2 To NbLignes
            If Ws.Range("A" & j) = Me.ComboBox1 Then
                k = k + 1
                ReDim Preserve a(k)
                ReDim Preserve b(k)
                a(k) = Ws.Range("B" & j)
                b(k) = j
            End If
        Next j
        For i = 1 To k - 1
            For j = i + 1 To k
                If a(i) > a(j) Then t = a(i): a(i) = a(j): a(j) = t: t = b(i): b(i) = b(j): b(j) = t
            Next j
        Next i
        For j = 1 To k
            .AddItem a(j)
            .List(.ListCount - 1, 1) = b(j)
        Next j
    End With
End Sub
Le 22/10/2017 à 17:20

Bonsoir h2so4, bonsoir à tous,

Désolé, cela ne fonctionne pas, j'ai le message d'erreur:

ERREUR DE COMPILATION:

Tableau déjà dimensionné..

Le 22/10/2017 à 18:11

remplace

Dim a(0), b(0)

par

Dim a(), b()
Le 22/10/2017 à 18:45

Re,

Alors maintenant le message d'erreur est:

ERREUR DE COMPILATION:

Variable non définie

Le 22/10/2017 à 23:41

Ajoute une instruction dim i

Le 23/10/2017 à 20:30

ERREUR DE COMPILATION:

Incompatibilité de type

Le 16/11/2017 à 19:14

Bonsoir à tous,

Personne n'a une idée?

Le 17/11/2017 à 17:02

bonsoir,

à ton avis pourquoi ne reçois-tu pas de réponse ?

edit : ben je vois que tu as reçu une belle réponse. Bonjour thev

Le 17/11/2017 à 17:28

Bonsoir,

Essayer ce code :

    Dim liste As Object, liste_triée As Object
    With Me.ComboBox2
        .Clear
        Set liste = CreateObject("system.collections.sortedlist")
        For j = 2 To NbLignes
            If Ws.Range("A" & j) = Me.ComboBox1 Then
                liste(Ws.Range("B" & j).Value) = Array(Ws.Range("B" & j).Value, j)
            End If
        Next j
        Set liste_triée = CreateObject("system.collections.arraylist"): liste_triée.addrange (liste.Values)
        If liste_triée.Count > 0 Then .List = Application.Transpose(Application.Transpose(liste_triée.toarray))
    End With
Le 19/11/2017 à 16:14
h2so4 a écrit :

bonsoir,

à ton avis pourquoi ne reçois-tu pas de réponse ?

edit : ben je vois que tu as reçu une belle réponse. Bonjour thev

Avec toutes mes excuses! Aurais-je commis une erreur, suis-je devenu un paria

Excusez-moi cela à été involontaire

Le 27/11/2017 à 16:43

Bonsoir Thev,

Désolé cela ne fonctionne toujours pas.

thev a écrit :

Bonsoir,

Essayer ce code :

    Dim liste As Object, liste_triée As Object
    With Me.ComboBox2
        .Clear
        Set liste = CreateObject("system.collections.sortedlist")
        For j = 2 To NbLignes
            If Ws.Range("A" & j) = Me.ComboBox1 Then
                liste(Ws.Range("B" & j).Value) = Array(Ws.Range("B" & j).Value, j)
            End If
        Next j
        Set liste_triée = CreateObject("system.collections.arraylist"): liste_triée.addrange (liste.Values)
        If liste_triée.Count > 0 Then .List = Application.Transpose(Application.Transpose(liste_triée.toarray))
    End With

Merci beaucoup

Le 27/11/2017 à 17:07

Bonsoir,

J'avais oublié une instruction mais je ne pense pas que ce soit le problème.

Quelle est l'erreur affichée ? Sinon pouvez-vous fournir un extrait non confidentiel de votre fichier. Ci-dessous code complet :

Private Sub ComboBox1_Change() 'Type de plat
    Dim j As Long
    Dim liste As Object, liste_triée As Object

    If Me.ComboBox1.ListIndex = -1 Then Exit Sub

    Nettoyage   'Lance le programme Nettoyage

    With Me.ComboBox2
        .Clear
        Set liste = CreateObject("system.collections.sortedlist")
        For j = 2 To NbLignes
            If Ws.Range("A" & j) = Me.ComboBox1 Then
                liste(Ws.Range("B" & j).Value) = Array(Ws.Range("B" & j).Value, j)
            End If
        Next j
        Set liste_triée = CreateObject("system.collections.arraylist"): liste_triée.addrange (liste.Values)
        If liste_triée.Count > 0 Then .List = Application.Transpose(Application.Transpose(liste_triée.toarray))
    End With

End Sub
Rechercher des sujets similaires à "trie liste deroulante"