XL 2016 Alimentation et tri dans lisbox

piga25

XLDnaute Barbatruc
Bonjour,
J'ai un problème de compréhension avec les codes de BOISGONTIER.
Lorsque j'ai moins de 4 lignes dans la base cela bug.
Je pense que cela vient de cette ligne dans initialize : NbCol = UBound(TblBD, 1) -1
De plus lorsqu'il y a aucune donnée dans les bases, il y a un problème d'affichage dans les listbox. Il faudrait qu'elle soit vide et que le premier item ajouté vienne bien sur la première ligne.
VB:
Option Compare Text
Dim Rng, TblBD(), NbCol, ligneEnreg
Private Sub UserForm_Initialize()
MultiPage1.Value = 0
Set f = Sheets("Annuaire")
'Alimente comboBox1
    a = f.Range("P2:P" & f.[P65000].End(xlUp).Row).Value
  Set AL = CreateObject("System.Collections.Arraylist")
  For i = LBound(a) To UBound(a)
    If Not AL.contains(a(i, 1)) Then AL.Add a(i, 1) 'enlève les doublons des n° d'équipe
  Next i
  AL.Sort
  Me.ComboBox1.List = AL.toarray
  Set AL = Nothing
'Alimente listBox1: Liste du planning
  a = f.Range("F2:I" & f.[F65000].End(xlUp).Row).Value
  ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2))
  Set SL = CreateObject("System.Collections.Sortedlist")
  For i = LBound(a) To UBound(a)
    SL.Add a(i, 1), Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)) 'Tri sur le n° de planning
  Next i
  Set AL = CreateObject("System.Collections.Arraylist")
  AL.AddRange SL.Values
  Me.ListBox1.Column = Application.Transpose(AL.toarray)
  Set SL = Nothing
  Set AL = Nothing
'Alimente ListBox2: Liste des équipes
  a = f.Range("P2:T" & f.[P65000].End(xlUp).Row).Value
  ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2))
  Set SL = CreateObject("System.Collections.Sortedlist")
  For i = LBound(a) To UBound(a)
    SL.Add a(i, 1) & a(i, 2), Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4), a(i, 5))
  Next i
  Set AL = CreateObject("System.Collections.Arraylist")
  AL.AddRange SL.Values
  Me.ListBox2.Column = Application.Transpose(AL.toarray)
  Me.ListBox5.Column = Application.Transpose(AL.toarray)
  Me.ListBox9.Column = Application.Transpose(AL.toarray)
  Set SL = Nothing
  Set AL = Nothing
'Alimente ListBox3: Liste de l'équipe sélectionnée
  Set Rng = f.Range("P2:T" & f.[P65000].End(xlUp).Row)
  TblBD = Rng.Value
  NbCol = UBound(TblBD, 1) - 1 '*** Ligne posant problème**Si moins de 4 lignes dans la base
  Set d = CreateObject("scripting.dictionary")
  d("*") = "" 'affiche la liste complète à l'initialyse
  For i = 1 To UBound(TblBD, 1): d(TblBD(i, 1)) = "": Next i
  Me.ComboBox1.List = d.keys
  Me.ComboBox1 = "*"
  Me.ListBox3.ColumnCount = NbCol
  Me.ListBox6.ColumnCount = NbCol
  Affiche
  Set Rng = Nothing
  Set d = Nothing
End Sub

Private Sub ComboBox1_click()
Affiche
End Sub

Sub Affiche() ' Ne retient que l'équipe recherchée
  n = 0
  Dim TblDest()
  Equipe = Me.ComboBox1
  For i = 1 To UBound(TblBD)
    If TblBD(i, 1) Like Equipe Then
      n = n + 1: ReDim Preserve TblDest(1 To UBound(TblBD, 1), 1 To n)
      For k = 1 To NbCol: TblDest(k, n) = TblBD(i, k): Next k
    End If
  Next i
  Me.ListBox3.Column = TblDest
  '---Tri par équipe
  a = Me.ListBox3.List
  Tri a, LBound(a), UBound(a), 0
  Me.ListBox3.List = a
  Me.ListBox7.List = a
  Me.ListBox8.List = a
  Me.TextBox16 = Me.ComboBox1
  Me.TextBox17 = Me.TextBox1
If Me.ComboBox1 <> "*" Then
Me.CommandButton16.Visible = True
Else
Me.CommandButton16.Visible = False
End If
End Sub

Sub Tri(a, gauc, droi, colTri)        ' Quick sort
colD = LBound(a, 2): colG = UBound(a, 2)
ref = a((gauc + droi) \ 2, colTri)
g = gauc: d = droi
Do
     Do While a(g, colTri) < ref: g = g + 1: Loop
     Do While ref < a(d, colTri): d = d - 1: Loop
     If g <= d Then
       For c = colD To colG
         Temp = a(g, c): a(g, c) = a(d, c): a(d, c) = Temp
       Next
       g = g + 1: d = d - 1
     End If
Loop While g <= d
If g < droi Then Call Tri(a, g, droi, colTri)
If gauc < d Then Call Tri(a, gauc, d, colTri)
End Sub
 

Pièces jointes

  • Gestion equipe V5.xlsm
    72.1 KB · Affichages: 6
Dernière édition:

piga25

XLDnaute Barbatruc
Bonjour,
J'ai trouvé pour la première partie, l'erreur vient bien de NbCol
Code:
NbCol = UBound(TblBD, 1) - 1
en 
NbCol = UBound(TblBD, 2)

Par contre j'ai toujours mon problème affiche dans la listbox quand la base est vide

VB:
Private Sub UserForm_Initialize()
MultiPage1.Value = 0
Set f = Sheets("Annuaire")
'Alimente comboBox1
    a = f.Range("P2:P" & f.[P65000].End(xlUp).Row).Value
  Set AL = CreateObject("System.Collections.Arraylist")
  For i = LBound(a) To UBound(a)
    If Not AL.contains(a(i, 1)) Then AL.Add a(i, 1) 'enlève les doublons des n° d'équipe
  Next i
  AL.Sort
  Me.ComboBox1.List = AL.toarray
  Set AL = Nothing
'Alimente listBox1: Liste du planning
  a = f.Range("F2:I" & f.[F65000].End(xlUp).Row).Value
  ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2))
  Set SL = CreateObject("System.Collections.Sortedlist")
  For i = LBound(a) To UBound(a)
    SL.Add a(i, 1), Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)) 'Tri sur le n° de planning
  Next i
  Set AL = CreateObject("System.Collections.Arraylist")
  AL.AddRange SL.Values
  Me.ListBox1.Column = Application.Transpose(AL.toarray)
  Set SL = Nothing
  Set AL = Nothing
'Alimente ListBox2: Liste des équipes
  a = f.Range("P2:T" & f.[P65000].End(xlUp).Row).Value
  ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2))
  Set SL = CreateObject("System.Collections.Sortedlist")
  For i = LBound(a) To UBound(a)
    SL.Add a(i, 1) & a(i, 2), Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4), a(i, 5))
  Next i
  Set AL = CreateObject("System.Collections.Arraylist")
  AL.AddRange SL.Values
  Me.ListBox2.Column = Application.Transpose(AL.toarray)
  Me.ListBox5.Column = Application.Transpose(AL.toarray)
  Me.ListBox9.Column = Application.Transpose(AL.toarray)
  Set SL = Nothing
  Set AL = Nothing
'Alimente ListBox3: Liste de l'équipe sélectionnée
  Set Rng = f.Range("P2:T" & f.[P65000].End(xlUp).Row)
  TblBD = Rng.Value
  NbCol = UBound(TblBD, 2) 'UBound(TblBD, 2) 1=ligne, 2=colonne
  Set d = CreateObject("scripting.dictionary")
  d("*") = "" 'affiche la liste complète à l'initialyse
  For i = 1 To UBound(TblBD, 1): d(TblBD(i, 1)) = "": Next i
  Me.ComboBox1.List = d.keys
  Me.ComboBox1 = "*"
  Me.ListBox3.ColumnCount = NbCol
  Me.ListBox6.ColumnCount = NbCol
  Affiche
  Set Rng = Nothing
  Set d = Nothing
End Sub
 

piga25

XLDnaute Barbatruc
Bonjour,

C'est bon j'ai trouvé, trop simple.
VB:
a = f.Range("F2:I" & f.[F65000].End(xlUp).Row).Value
mettre
a = f.Range("F2:I" & f.[F65000].End(xlUp).Row + 1).Value

Par contre quand il y a une donnée, cela bug encore
 

piga25

XLDnaute Barbatruc
Bonjour Chti160, le forum
Oui c'est bien de là que vient le problème, mais je ne suis jamais arriver à comprendre ce fonctionnement et à mettre cette condition.
Dans le principe je pense qu'il faut tester ou est situé la dernière ligne remplie.
Puis de mettre une condition, si c'est l'entete (ligne 1) charger la listbox uniquement avec la ligne 2,
et si c'est la ligne 2 ou plus, alors charger la listbox avec la base complète.
Le problème qui se pose c'est que cette listbox est triée, est-ce c'est cela qui entre en conflit ??
 

ChTi160

XLDnaute Barbatruc
Re
Un truc dans ce genre (je te laisse mettre a jour (car je n'ai pas les tenants et les aboutissants Lol)
VB:
Option Compare Text
Dim Rng, TblBD(), NbCol, ligneEnreg
Private Sub UserForm_Initialize()
Dim R As Integer
MultiPage1.Value = 0
Set f = Sheets("Annuaire")
'Alimente comboBox1
  R = f.[P65000].End(xlUp).Row
If R = 1 Then GoTo suite1: Exit Sub
    a = f.Range("P2:P" & R).Value
  Set AL = CreateObject("System.Collections.Arraylist")
  For i = LBound(a) To UBound(a)
    If Not AL.contains(a(i, 1)) Then AL.Add a(i, 1) 'enlève les doublons des n° d'équipe
  Next i
  AL.Sort
  Me.ComboBox1.List = AL.toarray
  Set AL = Nothing
'Alimente listBox1: Liste du planning
suite1:
 R = f.[F65000].End(xlUp).Row
If R = 1 Then GoTo suite2: Exit Sub
   a = f.Range("F2:I" & R).Value
  ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2))
  Set SL = CreateObject("System.Collections.Sortedlist")
  For i = LBound(a) To UBound(a)
    SL.Add a(i, 1), Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)) 'Tri sur le n° de planning
  Next i
  Set AL = CreateObject("System.Collections.Arraylist")
  AL.AddRange SL.Values
  Me.ListBox1.Column = Application.Transpose(AL.toarray)
  Set SL = Nothing
  Set AL = Nothing
'Alimente ListBox2: Liste des équipes
suite2 :
  R = f.[P65000].End(xlUp).Row
If R = 1 Then GoTo suite3: Exit Sub
  a = f.Range("P2:T" & R).Value
  ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2))
  Set SL = CreateObject("System.Collections.Sortedlist")
  For i = LBound(a) To UBound(a)
    SL.Add a(i, 1) & a(i, 2), Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4), a(i, 5))
  Next i
  Set AL = CreateObject("System.Collections.Arraylist")
  AL.AddRange SL.Values
  Me.ListBox2.Column = Application.Transpose(AL.toarray)
  Me.ListBox5.Column = Application.Transpose(AL.toarray)
  Me.ListBox9.Column = Application.Transpose(AL.toarray)
  Set SL = Nothing
  Set AL = Nothing
'Alimente ListBox3: Liste de l'équipe sélectionnée
suite3 :
 R = f.[P65000].End(xlUp).Row
If R = 1 Then GoTo suite4: Exit Sub
  Set Rng = f.Range("P2:T" & R)
  TblBD = Rng.Value
  NbCol = UBound(TblBD, 1) - 1 '*** Ligne posant problème**Si moins de 4 lignes dans la base
  Set d = CreateObject("scripting.dictionary")
  d("*") = "" 'affiche la liste complète à l'initialyse
  For i = 1 To UBound(TblBD, 1): d(TblBD(i, 1)) = "": Next i
  Me.ComboBox1.List = d.keys
  Me.ComboBox1 = "*"
  Me.ListBox3.ColumnCount = NbCol
  Me.ListBox6.ColumnCount = NbCol
  Affiche
  suite4 :
  Set Rng = Nothing
  Set d = Nothing
End Sub
jean marie
 

piga25

XLDnaute Barbatruc
Re,
Désolé mais cela ne fonctionne pas. C'est bon quand la liste située en Col P à T est vide, mais dès qu'une donnée est entrée sur la seconde ligne et suivante cela bug.

Peut être revoir entièrement la procédure initialize.
C'est à dire, séparer les commandes de tries dans des procédures différentes et se réalisant après le chargement des listbox

Conditions :
4 listes dans les bases de la feuille "ANNUAIRE":
- 1 : Col A à D non concerné par cet Userform
- 2: Col F à I
- 3: Col K à N non concerné par cet Userform
- 4: Col P à T
Combobox1: récupère les données Col P sans doublon et ayant un * comme valeur par défaut
Listbox1 : Base Col F à I
Listbox2 : Base Col P à T classée ordre croissant col P
Listbox3: Base Col P à T classée ordre croissant Col P si Combobox1 à * (Idem Listbox2)
Si valeur Combobox1 <> *, les lignes de la liste 4 et uniquement les valeurs correspondantes à la combobox1 se trouvant en Col P.

Franchement je ne sais comment faire faire pour résoudre ce problème.
 

piga25

XLDnaute Barbatruc
Re
Au premier test cela à l'air de bien fonctionner. Merci
Néanmoins j'ai modifié une ligne
VB:
If R = 1 Then GoTo suite4: Exit Sub
en
If R = 1 Then GoTo suite1: Exit Sub
de cette façon la listbox1 est bien renseignée même si les autres sont vides.

Il faudra que j'ajoute une procédure ou que je trouve comment classer par ordre croissant la combobox1

Vu les annonces faites pour le déconfinement et mon département (25) je pense passer encore de bon moment devant l'ordi.
 
Haut Bas