Trier Listbox à l'ajout des données (Trier par date) Le sujet est résolu

Y compris Power BI, Power Query et toute autre question en lien avec Excel
Avatar du membre
GGautier
Membre dévoué
Membre dévoué
Messages : 702
Appréciations reçues : 32
Inscrit le : 18 décembre 2018
Version d'Excel : 2016 FR

Message par GGautier » 27 septembre 2019, 10:05

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 :)
"Il n'y a pas de question idiote, seulement une réponse idiote" ALBERT EINSTEIN (enfin ici on évite). 8-)
Vous cherchez des réponses à vos questions ? regardez par ici ;) http://boisgontierjacques.free.fr/index2.htm
G
GVIALLES
Membre dévoué
Membre dévoué
Messages : 771
Appréciations reçues : 66
Inscrit le : 28 novembre 2017
Version d'Excel : 2016, 360
Téléchargements : Mes applications

Message par GVIALLES » 27 septembre 2019, 15:53

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.
ClasseurTriDate_GVS.xlsm
(25.66 Kio) Téléchargé 14 fois
Cordialement,

Gérard
Avatar du membre
GGautier
Membre dévoué
Membre dévoué
Messages : 702
Appréciations reçues : 32
Inscrit le : 18 décembre 2018
Version d'Excel : 2016 FR

Message par GGautier » 30 septembre 2019, 11:02

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
"Il n'y a pas de question idiote, seulement une réponse idiote" ALBERT EINSTEIN (enfin ici on évite). 8-)
Vous cherchez des réponses à vos questions ? regardez par ici ;) http://boisgontierjacques.free.fr/index2.htm
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message