ListBox con ordinamento dinamico.

Stato
Chiusa ad ulteriori risposte.

Zer0Kelvin

VBA Expert
Expert
19 Novembre 2016
1.626
63
59
Teramo (Provincia)
zer0kelvin.altervista.org
2010
112
Ciao a tutti.



A volte si ha l’esigenza di avere una ListBox in cui i valori siano ordinati alfabeticamente.

A me è successo diverse volte ed ho messo a punto alcune procedure che permettono di effettuare un ordinamento dinamico per ognuna delle colonne della ListBox.

Vista la tragica lentezza (in VBA almeno) del BubbleSort nell’effettuare l’ordinamento di una ListBox, ho deciso di sfruttare l’ordinamento di Excel, che è piuttosto efficiente; infatti, per ordinare la lista, il programma copia su un foglio temporaneo il contenuto della listbox, effettua l’ordinamento e ricarica la ListBox con i valori ordinati.

Questo è il codice indispensabile nella UserForm
Codice:
Option Explicit

Private Labels As Collection

Private Sub CommandButton3_Click()
    Unload Me
End Sub

Private Sub UserForm_Initialize()
    With ThisWorkbook.Sheets("DATI").ListObjects("Tabella") 'la tabella che contiene i dati da visualizzare
        If Not .DataBodyRange Is Nothing Then 'se la tabella non è vuota
            SetColumnwidths "ListBox1", Me.Controls, .ListColumns.Count, 1 'regola la larghezza delle colonne rispetto a quella delle etichette
            Me.ListBox1.List = .DataBodyRange.Value 'carica i dati nella ListBox
            Set Labels = SetSortLabels(Me, "Label", Me.ListBox1, 1, 6) 'inizializza le label per l'ordinamento, da Label1 a Label6
        End If
    End With
End Sub

Private Sub UserForm_Terminate()
    Set Labels = Nothing
End Sub
Questo è il codice da inserire in un modulo standard
Codice:
Option Explicit


Public Function SetSortLabels(ByVal UF As msforms.UserForm, ByVal BaseName As String, ByVal Lista As msforms.ListBox, lStart As Long, lCount As Long) As Collection
Dim I As Long
Dim mcmd As obSortLABEL
Dim SortLabelsCollection As Collection
    Set SortLabelsCollection = New Collection
    For I = lStart To lCount
        Set mcmd = New obSortLABEL
        Set mcmd.cmd = UF.Controls(BaseName & I)
        mcmd.InitSortLabel Lista, I - lStart + 1
        SortLabelsCollection.Add mcmd
    Next I
    Set SetSortLabels = SortLabelsCollection
End Function

Public Sub SetColumnwidths(aLBname As String, ByVal aControls As msforms.Controls, _
                            aColumncount As Long, StartLabel As Long)
'imposta la larghezza delle colonne della listbox in base alla larghezza delle relative label di intestazione
Dim I As Byte, CW As String
    With aControls(aLBname)
        .Clear
        .ColumnCount = aColumncount
        CW = ""
        For I = StartLabel To StartLabel + aColumncount - 1
            If CW <> "" Then CW = CW & ";"
            CW = CW & Format(aControls("Label" & I).Width)
        Next I
        .ColumnWidths = CW
    End With
End Sub

Public Sub SortListBox(Lb As Variant, byColumn As Long, Optional SortOrder As String)
'ordina la listbox in base ad una colonna
Static Ordinamento As XlSortOrder
Static LBprecedente As String
Static COLprecedente As Long
Dim ShTemp As Worksheet
Dim rTemp As Range
    With Lb
        If .ListCount > 0 Then
            If SortOrder = "A" Then Ordinamento = 0
            If Ordinamento = 0 Then
                Ordinamento = xlAscending
            Else
                If (Lb.Name = LBprecedente) And (byColumn = COLprecedente) Then 'se si clicca nuovamente sulla stessa etichetta
                    If Ordinamento = xlAscending Then Ordinamento = xlDescending Else Ordinamento = xlAscending 'alterna ordinamento A-Z e Z-A
                Else
                    Ordinamento = xlAscending
                End If
            End If
            Application.ScreenUpdating = False
            Application.DisplayAlerts = False
            Set ShTemp = ThisWorkbook.Worksheets.Add 'foglio temporaneo usato per l'ordinamento
            Set rTemp = ShTemp.Range("A1").Resize(.ListCount, .ColumnCount)
            rTemp = .List 'copia i dati nel foglio temporaneo
            With ShTemp.Sort 'effettua l'ordinamento
                .SortFields.Clear
                .SortFields.Add Key:=rTemp.Columns(byColumn), _
                    SortOn:=xlSortOnValues, order:=Ordinamento, DataOption:=xlSortNormal
                .SetRange rTemp
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .Apply
            End With
            .List = rTemp.Value 'carica la lista ordinata nella listbox
            ShTemp.Delete 'elimina il foglio temporaneo usato per l'ordinamento
            Set rTemp = Nothing
            Set ShTemp = Nothing
            Application.ScreenUpdating = True
            Application.DisplayAlerts = True
        End If
    End With
    LBprecedente = Lb.Name
    COLprecedente = byColumn
End Sub
Questo è il codice di un modulo di classe che ho chiamato obSortLABEL per le label che effettuano l'ordinamento
Codice:
Option Explicit

Public WithEvents cmd As msforms.Label
Private myList As msforms.ListBox
Private myCol As Long
Private bColor As Long, fColor As Long


Private Sub cmd_Click()
    SortListBox myList, myCol
End Sub

Public Sub InitSortLabel(ByVal List As msforms.ListBox, ByVal Colonna As Long)
    Set myList = List
    myCol = Colonna
End Sub

Private Sub cmd_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'cambia il dolore dell'etichetta mentre si clicca col mouse
    bColor = cmd.BackColor
    fColor = cmd.ForeColor
    cmd.BackColor = fColor
    cmd.ForeColor = bColor
End Sub

Private Sub cmd_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'ripristina il colore
    cmd.BackColor = bColor
    cmd.ForeColor = fColor
End Sub
Le sub cmd_MouseDown e cmd_MouseUp non sono essenziali e servono solo a modificare il colore della label durante il click del mouse.
Allego file di esempio.
 

Allegati

ges

Excel/VBA Expert
Amministratore
Expert
21 Giugno 2015
21.687
1.733
Como
2011MAC 2016WIN
463
Grande intuizione, complimenti Zer0!!!(y):)
Se c'è il foglio Excel perché, giustamente, non sfruttarlo.

Grazie per la condivisione.(y)
 

Marius44

VBA Expert
Moderatore
Expert
9 Settembre 2015
5.833
83
75
Catania
Excel2010
163
Stava per sfuggirmi questa bellissima, geniale, lodevole ... fatica di Z0°k
Grazie per la condivisione (avrà un posto d'onore nella mia cassetta degli attrezzi)

Ciao,
Mario
 

Zer0Kelvin

VBA Expert
Expert
19 Novembre 2016
1.626
63
59
Teramo (Provincia)
zer0kelvin.altervista.org
2010
112
Mi sono accorto che c'è un errore nella sub SetSortLabels nel modulo Mod_LBox .
Questa è la correzione necessaria
Codice:
Public Function SetSortLabels(ByVal UF As msforms.UserForm, ByVal BaseName As String, ByVal Lista As msforms.ListBox, lStart As Long, lCount As Long) As Collection
Dim I As Long
Dim mcmd As obSortLABEL
Dim SortLabelsCollection As Collection
    Set SortLabelsCollection = New Collection
    For I = lStart To lStart + lCount - 1 '<<==== correzione
 
Stato
Chiusa ad ulteriori risposte.

Sostieni ForumExcel

Aiutaci a sostenere le spese e a mantenere online la community attraverso una libera donazione!