XL 2019 Tri d'un listbox à partir de variables tableaux (en "dur" dans le code)

  • Initiateur de la discussion Initiateur de la discussion Street filou
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S

Street filou

Guest
Bonjour à tous

voila plusieurs jours que je galère pour adapter le code M. Boisgontier, qui fait référence à une plage de cellule, qui peux être triée via un combo (sur la 3eme colonne) dans un listbox,
hors moi je souhaite faire exactement la même chose mais à partir de variables tableaux "grattées" en dur dans le code comme plus bas et à partir de la 1ère colonne

l'idée est de remonter : boucherie et cremerie dans le combobox => et trier le listbox en fonction

Si quelqu'un pouvait me modifier le code (plus bas) pour pouvoir y arriver ce serait vraiment sympa, car là je sèche fortement !

merci par avance si quelqu'un avait une idée.
bonne soirée à tous




tableau de variables (en vraie il est plus grand 43 lignes et 19 colonnes)

Dim bd(6, 2) As Variant

bd(0, 0) = "boucherie"
bd(0, 1) = "boeuf"

bd(1, 0) = "boucherie"
bd(1, 1) = "lapin"

bd(2, 0) = "boucherie"
bd(2, 1) = "volaille"

bd(3, 0) = "cremerie"
bd(3, 1) = "yahourt"

bd(4, 0) = "cremerie"
bd(4, 1) = "beurre"

bd(5, 0) = "cremerie"
bd(5, 1) = "creme fraiche"


et voici le code original de M. Boisgontier

Dim f, bd
Option Compare Text
---------------------------------------------------------------
Private Sub UserForm_Initialize()

Set f = Sheets("bd")
Set d = CreateObject("Scripting.Dictionary")
bd = f.Range("A2😀" & f.[A65000].End(xlUp).Row).Value

Me.ListBox1.List = bd
For i = LBound(bd) To UBound(bd)
d(bd(i, 3)) = ""
Next i
Me.ComboBox1.List = d.keys
End Sub
Private Sub ComboBox1_click()
ville = Me.ComboBox1
n = 0
Me.ListBox1.Clear
For i = LBound(bd) To UBound(bd)
If bd(i, 3) = ville Then
Me.ListBox1.AddItem bd(i, 1)
Me.ListBox1.List(n, 1) = bd(i, 2)
Me.ListBox1.List(n, 2) = bd(i, 3)
Me.ListBox1.List(n, 3) = bd(i, 4)
n = n + 1
End If
Next i
End Sub
--------------------------------------------------------------------------------------------
Private Sub B_recup_Click()
'Sheets("Recup").[A2].Resize(Me.ListBox1.ListCount, 4).Value2 = Me.ListBox1.List
'a = Me.ListBox1.Column
'Sheets("Recup").[A2].Resize(UBound(a, 2) + 1, UBound(a) + 1).Value2 = Application.Transpose(a)
a = Me.ListBox1.List
Sheets("Recup").[A2].Resize(UBound(a) + 1, UBound(a, 2) + 1).Value2 = a
End Sub
 
Bonjour,
Je sais pas si ça va t'aider mais voici un bout de code qui trie un tableau à 2 dimensions
VB:
'------------------------------------
'Sort 2 dimension table on 2 criteria
'------------------------------------
Sub Sort2Dim2Crit(ByRef t As Variant, ByVal SortColumn1 As Integer, ByVal SortColumn2 As Integer)
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim Swap As Long
    Dim tElement() As Variant

    ReDim tElement(LBound(t, 2) To UBound(t, 2))

    k = UBound(t, 1)
    Do
        Swap = 0
        
        For i = LBound(t, 1) To k - 1
            If t(i, SortColumn1) > t(i + 1, SortColumn1) Then
                GoSub Swap
            ElseIf t(i, SortColumn1) = t(i + 1, SortColumn1) Then
                If t(i, SortColumn2) > t(i + 1, SortColumn2) Then GoSub Swap
            End If
        Next i
        
        k = Swap
    Loop While Swap
    Exit Sub
    
Swap:
    Swap = i
    For j = LBound(tElement) To UBound(tElement)
        tElement(j) = t(i, j)
    Next j
    For j = LBound(tElement) To UBound(tElement)
        t(i, j) = t(i + 1, j)
    Next j
    For j = LBound(tElement) To UBound(tElement)
        t(i + 1, j) = tElement(j)
    Next j
    
    Return
End Sub
Exemple d'appel:
VB:
Sub a()
    Dim t As Variant
    t = Range("A1:B6").Value
    Call Sort2Dim2Crit(t, 1, 2)
    Range("A1:B6").Value = t
End Sub
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD
Assurez vous de marquer un message comme solution pour une meilleure transparence.

Discussions similaires

Réponses
10
Affichages
632
Réponses
15
Affichages
650
Réponses
3
Affichages
901
Réponses
5
Affichages
837
Réponses
40
Affichages
3 K
Retour