Macro pour identifer les dates périmées

[gaara35]

Bonjour,

J'aimerais créer un bouton VBA avec macro, lorsque je clique deçu, j'aimerais que excel me remonte automatiquement toutes les dates dépassées par rapport à la date du jour. J'ai juste besoin de la formule à insérer dans la macro, je joints un exemple de mon fichier 🙂

La colonne concernée par la macro est "validité agrément"

Merci, si quelqu'un peut m'aider 😉

 

[camarchepas]

Re : Macro pour identifer les dates périmées

Bonjour Gaara,

Bon , une proposition que j'ai fais il y a pas longtemps , hier je crois et qui fonctionne.

J'ai pas trop le temps d'ouvrir ton fichier.

Regardes si tu arrive à intégrer , sinon reviens vers moi , d'ailleurs si tu y arrives aussi , c'est toujours sympa d'avoir un retour.

Dim EcartJour as long 
'Cherche est la date du jour soit 
Cherche = date
'Datelue est la date à vérifiée, ceci à mettre à l'intérieur de la boucle de scrutation des occurences
     EcartJour = DateDiff("d", Cherche, DateLue)
       If EcartJour < 0  Then

 

[Modeste geedee]

Re : Macro pour identifer les dates périmées

Bonsour®

utiliser le filtre personnalisé :

on pourra éventuellement rajouter un bouton :

 

[kjin]

Re : Macro pour identifer les dates périmées

Salut,

Sub zzzzzzzz()
Dim dJour#, rngf As Range, rng As Range, i#, j#, texte$
ActiveSheet.AutoFilterMode = False
dJour = Date
Application.ScreenUpdating = False
Range("B6").AutoFilter Field:=5, Criteria1:="<" & dJour
Set rngf = ActiveSheet.AutoFilter.Range
With rngf
    On Error Resume Next
    Set rng = .Offset(1).Resize(.Rows.Count - 1, 5).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If Not rng Is Nothing Then
        For i = 1 To rng.Areas.Count
            For j = 1 To rng.Areas(i).Rows.Count
                texte = texte & rng.Areas(i).Cells(j, 2) & " périmé le " & rng.Areas(i).Cells(j, 5) & vbCrLf
            Next
        Next
        MsgBox texte
    Else
        MsgBox "rien à afficher"
        ActiveSheet.AutoFilterMode = False
    End If
End With
ActiveSheet.AutoFilterMode = False
End Sub

A+
kjin

 

[gaara35]

Re : Macro pour identifer les dates périmées

Salut,

Sub zzzzzzzz()
Dim dJour#, rngf As Range, rng As Range, i#, j#, texte$
ActiveSheet.AutoFilterMode = False
dJour = Date
Application.ScreenUpdating = False
Range("B6").AutoFilter Field:=5, Criteria1:="<" & dJour
Set rngf = ActiveSheet.AutoFilter.Range
With rngf
    On Error Resume Next
    Set rng = .Offset(1).Resize(.Rows.Count - 1, 5).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If Not rng Is Nothing Then
        For i = 1 To rng.Areas.Count
            For j = 1 To rng.Areas(i).Rows.Count
                texte = texte & rng.Areas(i).Cells(j, 2) & " périmé le " & rng.Areas(i).Cells(j, 5) & vbCrLf
            Next
        Next
        MsgBox texte
    Else
        MsgBox "rien à afficher"
        ActiveSheet.AutoFilterMode = False
    End If
End With
ActiveSheet.AutoFilterMode = False
End Sub

A+
kjin

Merci à tous pour votre aide et contribution,

pour la solution que je quote juste au dessus, que faut t-il changer dans la macro pour que l'affichage (boite de dialogue) ce fasse par rapport à ce qui est écrit dans la colonne B et non les info de la colonne c ?

Merci beaucoup pour vos réponses 🙂

 

[kjin]

Re : Macro pour identifer les dates périmées

Re,

pour la solution que je quote juste au dessus....

Il a un nom, le gars....non ?! 🙄

Remplaces colonne 2 par colonne 1

For j = 1 To rng.Areas(i).Rows.Count
      texte = texte & rng.Areas(i).Cells(j, 1) & " périmé le " & rng.Areas(i).Cells(j, 5) & vbCrLf
 Next

kjin

 

[gaara35]

Re : Macro pour identifer les dates périmées

Re,

Il a un nom, le gars....non ?! 🙄

Remplaces colonne 2 par colonne 1

For j = 1 To rng.Areas(i).Rows.Count
      texte = texte & rng.Areas(i).Cells(j, 1) & " périmé le " & rng.Areas(i).Cells(j, 5) & vbCrLf
 Next

kjin

Merci Kjin de t'occuper de mon problème 🙂

Effetivement la modifcation marche bien dans le tableau test que j'ai posté mais dès que je veux reporter cette macro dans mon tableau original, ça me bloque (c'est surement parce que il y a plusieurs lignes de données dans les cellules concernés, pas seulement les lettres a, b, c, d, e, f ?)
Est ce possible de trouver le probleme au vu du fichier joint ?

Merci Kjin!

 

[kjin]

Re : Macro pour identifer les dates périmées

Re,
La colonne A n'est pas vide !, donc à remplacer par le code suivant

Sub zzzzzzzz()
Dim dJour#, rngf As Range, rng As Range, i#, j#, texte$
ActiveSheet.AutoFilterMode = False
dJour = Date
Application.ScreenUpdating = False
Range("A15").AutoFilter Field:=6, Criteria1:="<" & dJour
Set rngf = ActiveSheet.AutoFilter.Range
With rngf
    On Error Resume Next
    Set rng = .Offset(1).Resize(.Rows.Count - 1, 5).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If Not rng Is Nothing Then
        For i = 1 To rng.Areas.Count
            For j = 1 To rng.Areas(i).Rows.Count
                texte = texte & rng.Areas(i).Cells(j, 2) & " périmé le " & rng.Areas(i).Cells(j, 6) & vbCrLf
            Next
        Next
        MsgBox texte
    Else
        MsgBox "rien à afficher"
        ActiveSheet.AutoFilterMode = False
    End If
End With
ActiveSheet.AutoFilterMode = False
End Sub

A+
kjin

 

[gaara35]

Re : Macro pour identifer les dates périmées

Re,
La colonne A n'est pas vide !, donc à remplacer par le code suivant

Sub zzzzzzzz()
Dim dJour#, rngf As Range, rng As Range, i#, j#, texte$
ActiveSheet.AutoFilterMode = False
dJour = Date
Application.ScreenUpdating = False
Range("A15").AutoFilter Field:=6, Criteria1:="<" & dJour
Set rngf = ActiveSheet.AutoFilter.Range
With rngf
    On Error Resume Next
    Set rng = .Offset(1).Resize(.Rows.Count - 1, 5).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If Not rng Is Nothing Then
        For i = 1 To rng.Areas.Count
            For j = 1 To rng.Areas(i).Rows.Count
                texte = texte & rng.Areas(i).Cells(j, 2) & " périmé le " & rng.Areas(i).Cells(j, 6) & vbCrLf
            Next
        Next
        MsgBox texte
    Else
        MsgBox "rien à afficher"
        ActiveSheet.AutoFilterMode = False
    End If
End With
ActiveSheet.AutoFilterMode = False
End Sub

A+
kjin

C'est parfait 🙂 je te remercie beaucoup pour ton aide Kjin ! 😉