ordinare una listbox a più colonne

Question

Salve a tutti,

rientrato a lavoro e subito inizio a rompere con le mie domande.

Vorrei sapere se possibile come poter ordinare una listbox con 4 colonne in funzione della colonna selezionata.

Per cercare di far ciò, ho inserito 4 command button in testa alla listbox e vorrei che la lista venga ordinata in base al command button selezionato.

Posto una immagine per farvi capire meglio cosa intendo.

Anticipatamente ringrazio

Saluti

Peppe

Answer 1

Ciao Giuseppe,

se ho capito qual è il tuo problema io avrei creato una procedura che si limita, presi i dati che sono già presenti nella UserForm in base al suo caricamento iniziale, ad ordinarli.

Il problema che ho riscontrato è con le date che se inizialmente vengono caricate nel formato gg/mm/aaaa nella fase di ordinamento vengono visualizzate nel loro valore.

Io avevo trovato questa soluzione che però risulta essere lenta se il numero di voci da ordinare diventa "importante".

Questo il codice utilizzato da inserire nella userform (ad esclusione dell'evento Initialize che deve essere il tuo:

'----

Option Explicit

Option Compare Text

Const ColDate As Integer = 4

Private Sub UserForm_Initialize()

  'N.B. sostituire il codice di caricamento dati iniziale con il proprio codice

  With Me

    With .ListBox1

      .RowSource = "Elenco"

      .ColumnCount = Range("Elenco").Columns.Count

    End With

  End With

End Sub

Private Sub CommandButton1_Click()

  'N.B. utilizzare gli eventi Click in base al nome del proprio CommandButton

  Call OrdinaListBox(0)

End Sub

Private Sub CommandButton2_Click()

  'N.B. utilizzare gli eventi Click in base al nome del proprio CommandButton

  Call OrdinaListBox(1)

End Sub

Private Sub CommandButton3_Click()

  'N.B. utilizzare gli eventi Click in base al nome del proprio CommandButton

  Call OrdinaListBox(2)

End Sub

Private Sub CommandButton4_Click()

  'N.B. utilizzare gli eventi Click in base al nome del proprio CommandButton

  Call OrdinaListBox(3)

End Sub

Sub OrdinaListBox(Colonna As Integer)

  Dim arrLBi() As Variant, arrLBf() As Variant

  Dim i As Long, t As Integer

  With Me.ListBox1

    ReDim arrLBi(LBound(.List, 1) To UBound(.List, 1), LBound(.List, 2) To UBound(.List, 2))

    For i = LBound(.List, 1) To UBound(.List, 1)

      For t = LBound(.List, 2) To UBound(.List, 2)

        If t = ColDate - 1 Then

          If Not IsNumeric(.List(i, t)) Then

            arrLBi(i, t) = DateValue(.List(i, t))

          Else

            arrLBi(i, t) = .List(i, t)

          End If

        Else

          arrLBi(i, t) = .List(i, t)

        End If

      Next t

    Next i

    arrLBi = SortArrayEasy(arrLBi, Colonna)

    ReDim arrLBf(LBound(arrLBi, 1) To UBound(arrLBi, 1), LBound(arrLBi, 2) To UBound(arrLBi, 2))

    For i = LBound(arrLBi, 1) To UBound(arrLBi, 1)

      For t = LBound(arrLBi, 2) To UBound(arrLBi, 2)

        If t = ColDate - 1 Then

          arrLBf(i, t) = Format(arrLBi(i, t), "dd/mm/yyyy")

        Else

          arrLBf(i, t) = arrLBi(i, t)

        End If

      Next t

    Next i

    If .RowSource <> "" Then

      .RowSource = ""

    Else

      .Clear

    End If

    .List = arrLBf()

  End With

End Sub

Public Function SortArrayEasy(arrDati As Variant, col As Integer)

  Dim temp As Variant

  Dim i As Long, j As Long, t As Long

  ReDim temp(LBound(arrDati, 2) To UBound(arrDati, 2))

  For i = LBound(arrDati, 1) To UBound(arrDati, 1)

      For j = i + 1 To UBound(arrDati, 1)

          If arrDati(i, col) > arrDati(j, col) Then

            For t = LBound(temp, 1) To UBound(temp, 1)

              temp(t) = arrDati(i, t)

            Next t

            For t = LBound(temp, 1) To UBound(temp, 1)

              arrDati(i, t) = arrDati(j, t)

            Next t

            For t = LBound(temp, 1) To UBound(temp, 1)

              arrDati(j, t) = temp(t)

            Next t

          End If

      Next j

  Next i

  SortArrayEasy = arrDati

End Function

'-----

Edit:

Qui trovi un file di esempio

Esempio

Answer 2

Ciao Giuseppe,

In attesa della tua risposta, ho sostituito la routine UserForm_Initialize con la seguente versione:

'=========>>

Private Sub UserForm_Initialize()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim LRow As Long, iRows As Long

    Dim i As Long

    Const iPrimoAnno As Long = "2015"

    Const iUltimoAnno As Long = 2030

    Const dPrimaData As Date = #1/1/2015#

    Const dUltimaData As Date = #12/31/2030#

    Const sFoglio As String = "ElencoCertificati"

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

    With SH

        LRow = LastRow(SH, .Columns("A:A"))

        Set RngList = .Range("A2:D" & LRow)

    End With

    iRows = iUltimoAnno - iPrimoAnno + 1

    With Me

        For i = 1 To 31

            .cbxStartDay.AddItem i

            .cbxEndDay.AddItem i

        Next i

        For i = 1 To 12

            .cbxStartMonth.AddItem i

            .cbxEndMonth.AddItem i

        Next i

        For i = iPrimoAnno To iUltimoAnno

            .cbxStartYear.AddItem i

            .cbxEndYear.AddItem i

        Next i

        With .cbxStartDay

            .Value = Day(dPrimaData)

            .ListRows = 31

        End With

        With .cbxStartMonth

            .Value = Month(dPrimaData)

            .ListRows = 12

        End With

        With .cbxStartYear

            .Value = Year(dPrimaData)

            .ListRows = iRows

        End With

        With .cbxEndDay

            .Value = Day(dUltimaData)

            .ListRows = 31

        End With

        With .cbxEndMonth

            .Value = Month(dUltimaData)

            .ListRows = 12

        End With

        With .cbxEndYear

            .Value = Year(dUltimaData)

            .ListRows = iRows

        End With

        .lbCertificates.List = RngList.Value

    End With

End Sub

'<<=========

===

Regards,

Norman

Answer 3

Ciao Giuseppe,

Ho fatto una piccola modifica al mio file di prova perchè ho notato che avevo inavvertitamente spostato il controllo ListBox per coprire i controlli CommandButton di ricerca.

===

Regards,

Norman


Answer 4

Norman mi hai anticipato :-)

Answer 5

Ciao Giuseppe,

Prova qualcosa del genere:-

In un modulo standard, incolla il seguente codice:

'=========>>

Option Explicit

'--------->>

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range, _

                        Optional minRow As Long = 1)

    If Rng Is Nothing Then

        Set Rng = SH.Cells

    End If

    On Error Resume Next

    LastRow = Rng.Find(What:="*", _

                       after:=Rng.Cells(1), _

                       Lookat:=xlPart, _

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByRows, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Row

    On Error GoTo 0

    If LastRow < minRow Then

        LastRow = minRow

    End If

End Function

'--------->>

Public Sub QuickSort(SortArray, col, L, R, bAscending)

'\ TomOgilvy: http://goo.gl/ninpZW

'Originally Posted by Jim Rech 10/20/98 Excel.Programming

'Modified to sort on first column of a two dimensional array

'Modified to handle a second dimension greater than 1 (or zero)

'Modified to do Ascending or Descending

    Dim i, j, X, Y, mm

    i = L

    j = R

    X = SortArray((L + R) / 2, col)

    If bAscending Then

        While (i <= j)

            While (SortArray(i, col) < X And i < R)

                i = i + 1

            Wend

            While (X < SortArray(j, col) And j > L)

                j = j - 1

            Wend

            If (i <= j) Then

                For mm = LBound(SortArray, 2) To UBound(SortArray, 2)

                    Y = SortArray(i, mm)

                    SortArray(i, mm) = SortArray(j, mm)

                    SortArray(j, mm) = Y

                Next mm

                i = i + 1

                j = j - 1

            End If

        Wend

    Else

        While (i <= j)

            While (SortArray(i, col) > X And i < R)

                i = i + 1

            Wend

            While (X > SortArray(j, col) And j > L)

                j = j - 1

            Wend

            If (i <= j) Then

                For mm = LBound(SortArray, 2) To UBound(SortArray, 2)

                    Y = SortArray(i, mm)

                    SortArray(i, mm) = SortArray(j, mm)

                    SortArray(j, mm) = Y

                Next mm

                i = i + 1

                j = j - 1

            End If

        Wend

    End If

    If (L < j) Then Call QuickSort(SortArray, col, L, j, bAscending)

    If (i < R) Then Call QuickSort(SortArray, col, i, R, bAscending)

End Sub

'<<=========

Nel modulo di codice della Userfor, incolla:

'=========>>

Option Explicit

Dim RngList As Range

'--------->>

Private Sub cbRank_Click()

    Call SortList(1)

End Sub

'--------->>

Private Sub CbName_Click()

    Call SortList(2)

End Sub

'--------->>

Private Sub cbCertificate_Click()

    Call SortList(3)

End Sub

'--------->>

Private Sub cbDate_Click()

    Call SortList(4)

End Sub

'--------->>

Private Sub SortList(iSortCol As Long)

    Dim arrCerts As Variant

    Dim dStartDate As Date, dEndDate As Date

    Dim startMonth As String, endMonth As String

    Dim arrMonths() As Variant, arrTemp() As Variant

    Dim sStartDate As String, sEndDate As String

    Dim i As Long, j As Long, k As Long

    arrCerts = RngList.Value

    arrMonths = Application.GetCustomListContents(4)

    startMonth = arrMonths(cbxStartMonth)

    endMonth = arrMonths(cbxEndMonth)

    sStartDate = cbxStartDay.Value _

               & " " & startMonth _

               & ", " & cbxStartYear.Value

    sEndDate = cbxEndDay.Value _

             & " " & endMonth _

             & ", " & cbxEndYear.Value

    dStartDate = DateValue(sStartDate)

    dEndDate = DateValue(sEndDate)

    For i = LBound(arrCerts) To UBound(arrCerts)

        If arrCerts(i, 4) >= dStartDate And arrCerts(i, 4) <= dEndDate Then

            j = j + 1

            ReDim Preserve arrTemp(1 To 4, 1 To j)

            For k = 1 To 4

                arrTemp(k, j) = arrCerts(i, k)

            Next k

        End If

    Next i

    arrTemp = Application.Transpose(arrTemp)

    QuickSort arrTemp, iSortCol, 1, j, True

    With Me.lbCertificates

        .Clear

        .List = arrTemp

    End With

End Sub

'--------->>

Private Sub UserForm_Initialize()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim LRow As Long

    Const dMinDate As Date = #1/1/2000#

    Const sFoglio As String = "ElencoCertificati"

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

    With SH

        LRow = LastRow(SH, .Columns("A:A"))

        Set RngList = .Range("A2:D" & LRow)

    End With

    With Me

        .cbxStartDay.Value = Day(dMinDate)

        .cbxStartMonth.Value = Month(dMinDate)

        .cbxStartYear.Value = Year(dMinDate)

        .cbxEndDay.Value = Day(Date)

        .cbxEndMonth.Value = Month(Date)

        .cbxEndYear.Value = Year(Date)

        .lbCertificates.List = RngList.Value

    End With

End Sub

'--------->>

Private Sub cbEsci_Click()

    Unload Me

End Sub

'<<=========

Potresti scaricare il mio file di esempio Giuseppe20160717.xlsm a:

https://www.dropbox.com/s/f8n6fszvzcirxga/Giuseppe20160617.xlsm?dl=0

Non ho aggiunto del codice per riempire i controlli ComboBox con i giorni, mesi e anni in quanto l'avresti già fatto tu e anche perche non credevo fosse necessario per dimostrare la mia soluzione,  Per gli scopi delle mie prove, mi sono limitato ad assicurarmi che questi controlli ComboBox fossero riempiti all'avvio della Userform. Ovviamente, potrò postare codice anche per questo compito se fosse utile.

===

Regards,

Norman