Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

Fichier Excel Anniversaire

  • Initiateur de la discussion Initiateur de la discussion JBARBE
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

JBARBE

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

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

Pièces jointes

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

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

Pièces jointes

Dernière édition:
Re : Fichier Excel Anniversaire

Re,

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

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

Code:
=DATE(ANNEE(AUJOURDHUI())+(DATE(ANNEE(AUJOURDHUI());MOIS(B2);JOUR(B2))<AUJOURDHUI());MOIS(B2);JOUR(B2))
La macro fait un tri suivant cette colonne :

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

Pièces jointes

Dernière édition:
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
7
Affichages
173
Réponses
15
Affichages
779
Réponses
2
Affichages
398
Réponses
4
Affichages
730
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…