Macro pour identifer les dates périmées

gaara35

XLDnaute Nouveau
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 ;)
 

Fichiers joints

camarchepas

XLDnaute Barbatruc
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.

Code:
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
 

kjin

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

Salut,
Code:
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
 

Fichiers joints

gaara35

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

Salut,
Code:
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

XLDnaute Barbatruc
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 ?! :rolleyes:

Remplaces colonne 2 par colonne 1
Code:
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

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

Re,

Il a un nom, le gars....non ?! :rolleyes:

Remplaces colonne 2 par colonne 1
Code:
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!
 

Fichiers joints

kjin

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

Re,
La colonne A n'est pas vide !, donc à remplacer par le code suivant
Code:
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

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

Re,
La colonne A n'est pas vide !, donc à remplacer par le code suivant
Code:
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 ! ;)
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas