Compléter une macro par un deuxième tri

libellule85

XLDnaute Accro
Bonsoir le forum,

Je remercie une nouvelle fois job75 pour la macro suivante : quand on met une date sans astérisque cela classe du plus ancien au plus récent, et quand on ajoute l'astérisque à une date cela classe du plus récent au plus ancien.
J'aimerais rajouter, si cela est possible, un deuxième classement : quand il y a un "x" dans la cellule de droite cela met la ligne en dernier suivant le classement choisi.
Actuellement, il faudrait que toutes les lignes barrées soient mises à la fin du classement (et classées par date) et si le classement est du plus ancien au plus récent il faudrait que les lignes barrées soient au début.
J'espère avoir été clair dans mes explications.
D'avance merci pour votre aide

VB:
Private Sub Worksheet_Change(ByVal Target As Range) 'Un grand merci à Job75 pour cette macro
Dim dat$
With ListObjects(1).DataBodyRange
    If Intersect(Target, .Columns(1)) Is Nothing Or Target.Count > 1 Then Exit Sub
    If Target = "" Then
        Rows(Target.Row).Delete
    Else
        If Right(Target, 1) = "*" Then dat = Replace(Target, "*", "")
        If IsDate(dat) Then Target = CDate(dat)
        .Sort .Columns(1), IIf(dat = "", 1, 2), Header:=xlYes
    End If
End With
End Sub
 

Fichiers joints

job75

XLDnaute Barbatruc
Bonsoir charmante(e?) libellule85,
Code:
Private Sub Worksheet_Change(ByVal Target As Range) 'Un grand merci à Job75 pour cette macro
Dim dat$
With ListObjects(1).DataBodyRange
    If Intersect(Target, .Columns(1)) Is Nothing Or Target.Count > 1 Then Exit Sub
    Application.EnableEvents = False
    On Error Resume Next
    If Target = "" Then
        Rows(Target.Row).Delete
    Else
        .Columns(7).NumberFormat = "0;;"
        .Columns(7).SpecialCells(xlCellTypeBlanks) = 0
        If Right(Target, 1) = "*" Then dat = Replace(Target, "*", "")
        If IsDate(dat) Then Target = CDate(dat)
        .Sort .Columns(7), IIf(dat = "", 1, 2), .Columns(1), , IIf(dat = "", 1, 2), Header:=xlYes
        .Columns(7).SpecialCells(xlCellTypeConstants, 1) = ""
    End If
    Application.EnableEvents = True
End With
End Sub
Bonne fin de soirée.
 
Dernière édition:

libellule85

XLDnaute Accro
Bonsoir Job75,
Tout d'abord merci pour ta réponse. Mais quand je met ta nouvelle macro à la place de l'ancienne et que je veux faire un essai, il ne se passe rien !
 

job75

XLDnaute Barbatruc
Re,

Et il ne se passe rien non plus quand on ajoute des dates sur votre fichier du post #1.

Le tableau Excel ne s'agrandit pas, le fichier est probablement vérolé.

Avec votre dernier fichier du 30 12 16 ci joint aucun problème.

A+
 

Fichiers joints

libellule85

XLDnaute Accro
Re,
Effectivement quand je reprends mon ancien fichier cela fonctionne, une nouvelle fois un grand grand merci pour ton aide...
 

Discussions similaires


Haut Bas