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