Fichier Excel Anniversaire

[JBARBE]

Bonjour,

J'ai effectué un fichier Excel xls afin qu'une boite de dialogue m’avertit de l'anniversaire du jour ou à venir d'une personne !

J'ai des formules dans les colonnes D-E-F-G qui je pense on pourrait supprimer et ainsi compléter la macro suivante !

De plus la macro m’avertit dans le mois les anniversaires à venir ! Mais lorsque la date du jour est en fin de mois ( exemple le 30) et que l'anniversaire et au début du mois suivant, je ne suis pas averti suffisamment tôt !

Merci à l'avance !

Sub ACTION()
Dim J As Integer
Application.ScreenUpdating = False
Sheets("Feuil1").Select
    Range("E2").Select
For J = 1 To 100
 If ActiveCell = "" And Range("Nombre").Value = 1 Then
 Range("Nombre") = ""
 Range("A1").Select
 Exit Sub
 ElseIf ActiveCell = Date And ActiveCell <> "" Then
 Range("Nombre").Value = 1
 NOM = ActiveCell.Offset(0, -4)
 NAISSANCE = ActiveCell.Offset(0, -3)
 AGES = ActiveCell.Offset(0, -2)
 AGES1 = ActiveCell.Offset(0, 1)
 If AGES1 <> "" Then
  MsgBox "AUJOURD'HUI Anniversaire de " & NOM & " Age " & AGES & " Ans le " & NAISSANCE
 Else
  MsgBox "Anniversaire de " & NOM & " Age " & AGES + 1 & " Ans le " & NAISSANCE
 End If
 ActiveCell.Offset(1, 0).Select
 Else
 ActiveCell.Offset(1, 0).Select
 End If
 Next J
   Range("A1").Select
 MsgBox "PAS D'ANNIVERSAIRE AUJOURD'HUI"
Application.ScreenUpdating = True
End Sub

 

[job75]

Re : Fichier Excel Anniversaire

Bonjour JBARBE,

Perso plutôt que des MsgBox dans tous les sens je préfère utiliser le filtre avancé (élaboré) :

Sub Bouton()
If ActiveSheet.DrawingObjects("Bouton 3").Text Like "Tout*" Then
  ActiveSheet.DrawingObjects("Bouton 3").Text = "ANNIVERSAIRES"
  On Error Resume Next
  ActiveSheet.ShowAllData
Else
  ActiveSheet.DrawingObjects("Bouton 3").Text = "Tout afficher"
  [D2].Formula = "=AND(DATE(YEAR(TODAY()),MONTH(B2),DAY(B2))>=TODAY(),DATE(YEAR(TODAY()),MONTH(B2),DAY(B2))<TODAY()+31)+(DATE(YEAR(TODAY())+1,MONTH(B2),DAY(B2))<TODAY()+31)"
  [A:C].AdvancedFilter xlFilterInPlace, [D1:D2]
  [D2] = ""
End If
End Sub

Le filtre affiche les anniversaires qui auront lieu dans les 30 jours.

Pour les anniversaires du jour une MFC colore les lignes.

Fichier joint.

Edit : j'ai simplifié le critère du filtre (formule en D2), 3 tests (au lieu de 4) suffisent.

A+

 

[job75]

Re : Fichier Excel Anniversaire

Re,

Pour classer les anniversaires on peut prévoir une colonne D avec cette formule en D2 :

=SI(DATE(ANNEE(AUJOURDHUI());MOIS(B2);JOUR(B2))>=AUJOURDHUI();DATE(ANNEE(AUJOURDHUI());MOIS(B2);JOUR(B2));DATE(ANNEE(AUJOURDHUI())+1;MOIS(B2);JOUR(B2)))

[EDIT] ou plus simplement :

=DATE(ANNEE(AUJOURDHUI())+(DATE(ANNEE(AUJOURDHUI());MOIS(B2);JOUR(B2))<AUJOURDHUI());MOIS(B2);JOUR(B2))

La macro fait un tri suivant cette colonne :

Sub Bouton()
If ActiveSheet.DrawingObjects("Bouton 3").Text Like "Tout*" Then
  ActiveSheet.DrawingObjects("Bouton 3").Text = "ANNIVERSAIRES"
  On Error Resume Next
  ActiveSheet.ShowAllData
Else
  ActiveSheet.DrawingObjects("Bouton 3").Text = "Tout afficher"
  [A:D].Sort [D1], xlAscending, Header:=xlYes 'tri
  [E2].Formula = "=AND(DATE(YEAR(TODAY()),MONTH(B2),DAY(B2))>=TODAY(),DATE(YEAR(TODAY()),MONTH(B2),DAY(B2))<TODAY()+31)+(DATE(YEAR(TODAY())+1,MONTH(B2),DAY(B2))<TODAY()+31)"
  [A:D].AdvancedFilter xlFilterInPlace, [E1:E2]
  [E2] = ""
End If
End Sub

Fichier (2).

A+

 

[JBARBE]

Re : Fichier Excel Anniversaire

Bonsoir,

Merci à vous tous de votre aide précieuse et à bientôt sur le Forum !

Bonne soirée !