XL 2019 Message en fonction d'une date

gilles37

XLDnaute Junior
Bonjour,

Je souhaite dans la macro ci-dessous envoyer un message diffèrent si échéance 3 mois et 1 mois

msg a 3 mois: bonjour, le dossier arrive a expiration..
msg à 1 mois: bonjour, il vous reste plus qu'un mois pour nous communiquer votre dossier

Je bloque

Merci pour votre aide😉




Sub Alerte_Mail()
'
' Alerte_Mail Macro
'

nbreligne = WorksheetFunction.CountA(Columns(2))
nbrealerte = 0
objet = "Renouvellement "
'corps = "test"
For indextab = 2 To nbreligne Step 1

corps = "Bonjour" & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "Le dossier.... : " & Range("A" & indextab).Value & " arrive à expiration." & Chr(13) & Chr(10) & Chr(13) & Chr(10) & " Nous vous prions de:" & Chr(13) & Chr(10) & "- Prévoir son renouvellement " & Chr(13) & Chr(10) & "- Vérifier ..." & Chr(13) & Chr(10) & "- De confirmer la liste " & Chr(13) & Chr(10) & Chr(13) & Chr(10) & " Une fois " & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "Bien cordialement,"

If Date = Date = DateAdd("m", -1, Range("G" & indextab).Value) Then


If Date = DateAdd("m", -3, Range("G" & indextab).Value) Or Date = DateAdd("m", -1, Range("G" & indextab).Value) Then
nbrealerte = nbrealerte + 1
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'corps du message si besoin
strbody = Contenu
With OutMail
.To = Range("J" & indextab).Value 'destinataire(s)
'.CC = "aaa@xx.com,bb@xx.com" ' copie
'.BCC = "aaa@xx.com,bb@xx.com" ' si BCC
.Subject = objet
.Body = corps
'Piece_jointe
'.Attachments.Add ("C:\test.txt") 'mettre chemin et fichier a joindre
'.Display 'ouvre Outlook
'or use
.Send 'envoi sans ouvrir Outlook
End With
Set OutMail = Nothing
Set OutApp = Nothing



End If
Next indextab
MsgBox ("Toutes les alertes ont été envoyé ! (nombre = " & nbrealerte & " )")


End Sub
 

fanch55

XLDnaute Accro
Bonjour,
le code ci-dessous devrait fonctionner :
VB:
Sub Alerte_Mail()
'
' Alerte_Mail Macro
'
dblf = vbLf & vbLf
nbreligne = WorksheetFunction.CountA(Columns(2))
nbrealerte = 0
objet = "Renouvellement "

For indextab = 2 To nbreligne Step 1
    
    Select Case DateDiff("m", Date, Range("G" & indextab)) ' en nombre de mois
        Case 3:     msg = "Le dossier arrive a expiration.."
        Case 1:     msg = "Il vous reste plus qu'un mois pour nous communiquer votre dossier"
        Case Else:  msg = vbNullString
    End Select

    If msg <> vbNullString Then
        corps = "Bonjour" & dblf & _
                msg & dblf & _
                "Nous vous prions de:" & vbLf & _
                " - Prévoir son renouvellement " & vbLf & _
                " - Vérifier ..." & vbLf & _
                " - De confirmer la liste " & dblf & _
                " Une fois " & dblf & _
                "Bien cordialement,"
        nbrealerte = nbrealerte + 1

        With CreateObject("Outlook.Application").CreateItem(0)
            .To = Range("J" & indextab).Value 'destinataire(s)
            '.CC = "aaa@xx.com,bb@xx.com" ' copie
            '.BCC = "aaa@xx.com,bb@xx.com" ' si BCC
            .Subject = objet
            .Body = corps
            'Piece_jointe
            '.Attachments.Add ("C:\test.txt") 'mettre chemin et fichier a joindre
            .Display True 'ouvre Outlook
            'or use
            '.Send 'envoi sans ouvrir Outlook
        End With

    End If
Next indextab

If nbrealerte > 0 Then MsgBox ("Toutes les alertes ont été envoyé ! (nombre = " & nbrealerte & " )")

End Sub
 

fanch55

XLDnaute Accro
Bonsoir,
Il doit me manquer qq chose .
Un fichier exemple serait le bienvenu, car je ne sais pas comment l'alerte_Mail est lancé,
et je ne sais pas ce qu'est la ligne 59 ...

Rien n'est envoyé automatiquement effectivement, car j'ai juste fait un display et non un Send, à vous de le modifier si vous le désirez ...
 

gilles37

XLDnaute Junior
Bonjour,

Désolé pour le retard,
Je souhaiterais deux messages distant qui partiraient 3 mois et 1 mois avant la date déchéance en appuyant sur "alerte mail"
De plus, il semblerait qu'a la ligne 59 la macro ne fonctionne plus, je ne comprends pas.
Merci pour l'aide que vous pourriez m'apporter.
 

Pièces jointes

  • RELANCE Copie.xlsm
    46.3 KB · Affichages: 10

gilles37

XLDnaute Junior
Bonjour,
La macro Alerte_Mail originelle ne faisant que 49 lignes, je ne sais toujours pas ce qu'est la ligne 59 ?
La macro dans le fichier fourni n'est pas complète et non exécutable ..
Bonjour,

Pour les deux messages differents, j'ai le fais avec 2 commandbutton et deux macros.
Par contre, j'ai toujours le souci, , qu il n'y a plas de message envoyage (donc n'analyse pas le tableau a partir la ligne 56. Je comprends pas.
Merci pour votre aide.
 

Pièces jointes

  • RELANCE PDP v4 .1 .0.1- Copy.xlsm
    160.6 KB · Affichages: 7

fanch55

XLDnaute Accro
Bonjour,
Au vu de la macro alerte_Mail2 dans le classeur envoyé :

nbreligne = WorksheetFunction.CountA(Columns(2))
Vous déterminez le nombre d'itérations à effectuer à partir du nombre de cellules non vides dans la colonne B,
colonne qui est masquée et qui concerne la Rue bien souvent non renseignée.
Il y a effectivement 56 cellules Rue renseignées, ce qui explique la fin de la boucle à la ligne 56 ...
Utilisez plutôt la colonne qui est directement concernée c'est à dire la colonne G

nbreligne = WorksheetFunction.CountA(Columns("G"))

Cependant, ce mode de calcul n'est pas conseillé car s'il y a des cellules non remplies en colonne "G" , vous aurez le même phénomène que pour la colonne 2

Pour déterminer le numéro de la dernière ligne jusqu'où itérer, utilisez plutôt :
( je ne l'avais pas fait dans la macro que je vous ai proposée car je ne connaissais pas le contexte)
VB:
       nbreligne = Cells(Rows.Count, "G").End(xlUp).Row

Vérifiez également la ligne 151 car le mois de septembre n'a pas 31 jours ...
 

Pièces jointes

  • RELANCE PDP v4 .1 .0.1- Copy.xlsm
    160.6 KB · Affichages: 8

Discussions similaires

Réponses
0
Affichages
456

Membres actuellement en ligne

Statistiques des forums

Discussions
291 667
Messages
1 916 971
Membres
179 500
dernier inscrit
oximo
Haut Bas