Trier les informations d'une liste déroulante

Toubabou · 26 Octobre 2017

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

Voici mon code:

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

Merci par avance

thebenoit59 · 26 Octobre 2017

Bonjour Toubabou.

Ce n'est franchement pas lisible, essaye de mettre le code entre balises.
Egalement, un fichier est utile.

Pour des fonctions de tri je t'invite à aller sur le site : http://boisgontierjacques.free.fr

Toubabou · 26 Octobre 2017

Oups pardon
Alors voici mon code:

Code:

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

Toubabou · 28 Octobre 2017

Bonjour à tous

Effectuez une recherche sur Excel Downloads...

Trier les informations d'une liste déroulante

Toubabou

XLDnaute Impliqué

thebenoit59

XLDnaute Accro

Toubabou

XLDnaute Impliqué

Toubabou

XLDnaute Impliqué

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums