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

Pièces jointes

  • Liste des agréments v1.0.xls
    31 KB · Affichages: 51
  • Liste des agréments v1.0.xls
    31 KB · Affichages: 48
  • Liste des agréments v1.0.xls
    31 KB · Affichages: 46

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
 

Modeste geedee

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

Bonsour®

utiliser le filtre personnalisé :
Capture.JPG
on pourra éventuellement rajouter un bouton :
 

Pièces jointes

  • Capture.JPG
    Capture.JPG
    52.7 KB · Affichages: 87
  • Capture.JPG
    Capture.JPG
    52.7 KB · Affichages: 83
  • Liste des agréments v1.0.xls
    66 KB · Affichages: 37
  • Liste des agréments v1.0.xls
    66 KB · Affichages: 31
  • Liste des agréments v1.0.xls
    66 KB · Affichages: 32

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
 

Pièces jointes

  • garra.xls
    29 KB · Affichages: 30
  • garra.xls
    29 KB · Affichages: 32
  • garra.xls
    29 KB · Affichages: 39

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

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!
 

Pièces jointes

  • garra.xls
    26.5 KB · Affichages: 31
  • Liste des agréments 2.xls
    35 KB · Affichages: 35
  • garra.xls
    26.5 KB · Affichages: 37
  • garra.xls
    26.5 KB · Affichages: 36

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 ! ;)
 

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 940
Membres
101 845
dernier inscrit
annesof