Trier Listbox à l'ajout des données (Trier par date)

Bonjour le forum

J'aimerais (comme l'indique le titre du sujet) trier mon ListBox par date. Je ne peux pas vous fournir le fichier car confidentiel à mon entreprise.

Je vous joint le code que j'utilise ci-dessous

Note : les dates se trouvent dans la colonne 1 du ListBox et le ListBox se trouve sur un UserForm

Private Sub CommandButton1_Click()
Me.ListBox1.Clear
If Not IsDate(Me.TextBox1) Or Not IsDate(Me.TextBox2) Then MsgBox "Merci de saisir une date au bon format", vbCritical, "Erreur": Exit Sub

For i = 7 To ThisWorkbook.Worksheets.Count
    Max = ThisWorkbook.Worksheets(i).Range("A" & Rows.Count).End(xlUp).Row
    For Each c In Worksheets(i).Range("A3:A" & Max)
        If c >= CDate(Me.TextBox1) And c <= CDate(Me.TextBox2) Then
            Lig = c.Row
            Me.ListBox1.AddItem
            Me.ListBox1.List(Me.ListBox1.ListCount - 1, 0) = Worksheets(i).Name
            For y = 1 To 9
                Me.ListBox1.List(Me.ListBox1.ListCount - 1, y) = Worksheets(i).Cells(Lig, y)
            Next y
        End If
    Next c
Next i

End Sub

Par avance merci de l’intérêt porté au sujet

Bonjour GGautier,

Je te propose de passer par la création d'une feuille de travail dans laquelle on recopie les données filtrées des autres feuilles puis que l'on trie sur la date. Ce qui donne :

Option Explicit
Private Sub CommandButton1_Click()
    Const cWorkingSheetName = "_TEMP_"
    Dim i As Integer, Max As Long, Lig As Long, y As Integer, lRow As Long
    Dim c As Range, oCell As Range
    Dim aData() As Variant, aDataSheet() As Variant
    Dim isWorkingSheetExists As Boolean
    Dim oWorkingSheet As Worksheet, oCurrentSheet As Worksheet

    Me.ListBox1.Clear
    If Not IsDate(Me.Textbox1) Or Not IsDate(Me.Textbox2) Then MsgBox "Merci de saisir une date au bon format", vbCritical, "Erreur": Exit Sub

    'On s'assure qu'il n'y a pas déjà de feuille de travail
    On Error Resume Next
    isWorkingSheetExists = False
    Set oWorkingSheet = ThisWorkbook.Worksheets(cWorkingSheetName)
    If Err = 0 Then
        isWorkingSheetExists = True
    End If
    On Error GoTo 0
    'Si elle existe, on le détruit
    If isWorkingSheetExists Then
        oWorkingSheet.Delete
    End If

    'On ajoute la feuille de travail après la dernière feuille
    Set oWorkingSheet = ThisWorkbook.Worksheets.Add(, Sheets(Sheets.Count))
    oWorkingSheet.Name = cWorkingSheetName

    'On recopie les données sélectionnées des feuilles 7 à ... dans la feuille de travail
    For i = 7 To ThisWorkbook.Worksheets.Count - 1
        'On affecte la feuille courante
        Set oCurrentSheet = ThisWorkbook.Worksheets(i)

        'On annule les filtres de la feuille courante au cas où il y en aurait
        On Error Resume Next
        oCurrentSheet.UsedRange.AutoFilter
        On Error GoTo 0

        'On récupère le numéro de la dernière ligne
        Max = oCurrentSheet.Range("A" & Rows.Count).End(xlUp).Row

        'On réfère la plage utile
        Set c = oCurrentSheet.Range("A2:G" & Max)

        'On filtre la plage utile courante suivant le choix des dates
        c.AutoFilter 1, ">=" & Format(CDate(Me.Textbox1), "mm/dd/yyyy") _
               , xlAnd, "<=" & Format(CDate(Me.Textbox2), "mm/dd/yyyy")
        oCurrentSheet.Activate

        'On recopie les données sélectionnées dans la feuille de travail
        c.SpecialCells(xlCellTypeVisible).Copy
        lRow = oWorkingSheet.UsedRange.Rows.Count
        If lRow = 1 Then lRow = 0
        oWorkingSheet.Cells(lRow + 1, 2).PasteSpecial
        oWorkingSheet.Activate
        'On ajoute le nom de la feuille
        For y = lRow + 1 To oWorkingSheet.UsedRange.Rows.Count
            oWorkingSheet.Cells(y, 1).Value = oCurrentSheet.Name
        Next
        'On supprime la ligne d'entête
        oWorkingSheet.Rows(lRow + 1).EntireRow.Delete
        'On annule les filtres de la feuille courante
        oCurrentSheet.UsedRange.AutoFilter
    Next

    'On trie les lignes de la feuille de travail sur la date
    oWorkingSheet.UsedRange.Sort oWorkingSheet.UsedRange.Columns(2), xlAscending

    'On renseigne la listbox
    For Each c In oWorkingSheet.UsedRange.Rows
        Me.ListBox1.AddItem
        For y = 1 To 9
            Me.ListBox1.List(Me.ListBox1.ListCount - 1, y) = oWorkingSheet.Cells(c.Row, y)
        Next y
    Next

    'On fait le ménage
    Application.DisplayAlerts = False
    oWorkingSheet.Delete
    Application.DisplayAlerts = True
    Set oWorkingSheet = Nothing
    Set oCurrentSheet = Nothing
    Set oCell = Nothing
    Set c = Nothing
End Sub

Je joins mon classeur de test.

Merci du retour, en attendant de voir ta réponse j'ai eu le temps de faire autre chose du coup ^^

Voilà un extrait du code que j'ai utilisé :

Pour la partie initialisation du userform :

Private Sub UserForm_Initialize()
  nomTableau = "Tableau1"
  TblBD = Range(nomTableau).Value
  For i = 1 To UBound(TblBD): TblBD(i, 4) = CDate(TblBD(i, 4)): Next i
  Me.ListBox1.ColumnCount = Range(nomTableau).Columns.Count + 1
  NbCol = Range(nomTableau).Columns.Count
  ColVisu = Array(1, 2, 3, 4, 5, 6, 7)    ' colonnes à visualiser (adapter)
  EnteteListBox
  '---- compte
  Set d = CreateObject("scripting.dictionary")
  d("*") = ""
  For i = LBound(TblBD) To UBound(TblBD)
    d(TblBD(i, 1)) = ""
  Next i
  Choix = d.keys
  Me.ComboBox1.List = Choix
  '---Dates
  Set d = CreateObject("scripting.dictionary")
  colDate = 4
  For i = LBound(TblBD) To UBound(TblBD)
    d(TblBD(i, colDate)) = ""
  Next i
  Dates = d.keys
  Tri Dates, LBound(Dates), UBound(Dates)
  Me.ComboBox2.List = Dates: Me.ComboBox2 = Dates(0)
  Me.ComboBox3.List = Dates: Me.ComboBox3 = Dates(UBound(Dates))
  Filtre
  Me.ComboTri.List = Application.Transpose(Range(nomTableau).Offset(-1).Resize(1))  ' Ordre tri
End Sub

Pour la partie filtre entre deux date :

Sub Filtre()
    Dim Tbl()
    clé = Me.ComboBox1: If clé = "" Then clé = "*"
    début = CDate(Me.ComboBox2)
    fin = CDate(Me.ComboBox3)
    colDate = 4
    n = 0
    totCredit = 0: totDebit = 0
    For i = LBound(TblBD) To UBound(TblBD)
      If TblBD(i, colDate) >= début And TblBD(i, colDate) <= fin And TblBD(i, 1) Like clé Then
        n = n + 1: ReDim Preserve Tbl(1 To NbCol + 1, 1 To n)
        c = 0
        For Each k In ColVisu
          c = c + 1: Tbl(c, n) = TblBD(i, k)
          If c = 6 Or c = 7 Then Tbl(c, n) = Tbl(c, n) '  Format(Tbl(c, n), "## 000 000")
        Next k
        totCredit = totCredit + TblBD(i, 7): totDebit = totDebit + TblBD(i, 6)
        c = c + 1: Tbl(c, n) = totCredit - totDebit   'Format(totCredit - totDebit, "## 000 000")   ' solde cumulé
       End If
     Next i
     '-- totaux
     If n > 0 Then
       Me.ListBox1.Column = Tbl
       Me.TotCred = Format(totCredit, "## 000 000"): Me.TotDeb = Format(totDebit, "## 000 000")
     Else
       Me.ListBox1.Clear
       Me.TotCred = 0: Me.TotDeb = 0
     End If
End Sub

Après pour ma part je n'ai récupéré du code que ce qui m’intéresse vraiment ! Pour les curieux j'ai eu ce code via le site de Jacques Boisgontier (http://boisgontierjacques.free.fr/index2.htm) et en particulier grâce à ce fichier : http://boisgontierjacques.free.fr/fichiers/Formulaire/CompteBancaire.xls

Rechercher des sujets similaires à "trier listbox ajout donnees date"