XL 2016 Macro VBA - Envoi mail automatique selon plusieurs échéances

LuanaDDC

XLDnaute Junior
Bonjour à tous,

J'espère que vous allez bien.

J'aurais besoin de vos précieux conseils, s'il vous plait pour m'aiguiller dans ma problématique qui peut paraître un peu complexe :(.

Je souhaite faire une macro qui envoi un mail automatiquement sur Outlook à une liste de mail, qui sera défini au préalable dans ma colonne H, un mail lorsque :
- Jours restants = 15
- Jours restants = 7
- Jours restants = 0
- Jours restants = -7
- Jours restants = -15

- Jours restant = -30 ou -31 (à la fin du mois)Ps: je sais ça fait beaucoup de relance ^^' mais c'est fait exprès.Concernant les jours restants "négatives", je souhaite intégrer dans ma formule deux adresses mails automatiques en plus de ceux qui sont mentionnés dans la colonne H (il me semble que je peux les insérer directement dans ma macro pour ce point). Ci-dessous un exemple du mon fichier.
1602600177584.png

Ci-dessous une macro que j'ai essayé d'adapter sauf que du coup je n'ai pas mes rappels et relances... Je ne sais pas si je dois mettre Option Explicit ou si je peux rajouter directement à la suite de If C.Offset(, 1) - Date = 15 avec un Else...
Le code ne veut rien ! ahah

Option Explicit
Const cSheetName ="Feuil1"
Const cColJoursRestants=15
Const cColMailRappel = 7
ConstcNbJoursJ = 0
Const cNbJoursRappel = -7
ConstcNbJoursRappel1 = -15
Const cNbJoursRappel2 = -30

Sub Alertes()
Dim C As Range, OL As Object, M As Object, Plage As Range
Set olApp = CreateObject("Outlook.application")
With Sheets("Feuil1")
Set Plage = .Range(.[G2], .Cells(.Rows.Count, 1).End(xlUp))
End With
For Each C In Plage
If C.Offset(, 1) - Date = 15 Then
Set M = olApp.CreateItem(olMailItem)
With M
.Subject = C.Offset(, 3)
.Body = C.Offset(, 4)
.Recipients.Add C.Offset(, 2)
'.display
.Send
End With
End If
Next C
End Sub



En tout cas merci beaucoup par avance pour votre aide. J'espère avoir été assez clair... Et désolée je suis débutante mais j'ai vraiment envie d'être autonome ^^ et pouvoir aider les autres par la suite.
Bonne soirée !
Cordialement.
 

Pièces jointes

  • TEST plonge.xlsm
    22.9 KB · Affichages: 51
Solution
Bonjour
Le mieux est de créer une colonne supplémentaire pour y mettre la 2ème adresse(même masquée)
Voici un code qui si la diff est plus grande de 0 don 7 ou 15 on prend l'adresse en col J sinon en col H
Bruno
VB:
Sub EnvoiMail()
Dim OutApp As Object
Dim OutMail As Object
For lig = 2 To [C65000].End(3).Row
n = Date - Cells(lig, 6)
If n = -15 Or n = -7 Or n = 0 Or n = 7 Or n = 15 Then
'''''''''si n >0 prend adresse en col J sinon en col H
noms=iif(n>0,noms & ";" & cells(lig,10),noms & ";" & cells(lig,8))
'noms = noms & ";" & Cells(lig, 8)
Cells(lig, 9) = Date
End If
Next
If noms = "" Then MsgBox "Rien envoyé", vbInformation, "AUCUNE RELANCE": Exit Sub
noms = Right(noms, Len(noms) - 1)
Set OutApp = CreateObject("outlook.application")
Set...

youky(BJ)

XLDnaute Barbatruc
Bonjour,
Voici un code qui le fait.
Supprimer tout le contenu de Module1 et coller ce code
Adapter le lieu ou ce situe le message
.Subject = Feuil2.[D2] 'le message
Bruno
VB:
Sub EnvoieMail()
Dim OutApp As Object
Dim OutMail As Object
For lig = 2 To [C65000].End(3).Row
n = Date - Cells(lig, 6)
If n = -15 Or n = -7 Or n = 0 Or n = 7 Or n = 15 Then
noms = noms & ";" & Cells(lig, 8)
End If
Next
noms = Right(noms, Len(noms) - 1)
Set OutApp = CreateObject("outlook.application")
Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = "DA-COSTA"
        .Cc = noms
       ' .Attachments.Add (rep & "\" & NomFic)
        .Subject = Feuil2.[D2] 'le message
        .Body = "RELANCE CONTROL" 'le titre
        .Display
        .Send
    End With
End Sub
 

youky(BJ)

XLDnaute Barbatruc
Petite correction pour éviter si rien car bug
et mettre la date d'envoie
Bruno
VB:
Sub EnvoieMail()
Dim OutApp As Object
Dim OutMail As Object
For lig = 2 To [C65000].End(3).Row
n = Date - Cells(lig, 6)
If n = -15 Or n = -7 Or n = 0 Or n = 7 Or n = 15 Then
noms = noms & ";" & Cells(lig, 8)
Cells(lig, 9) = Date
End If
Next
If noms = "" Then MsgBox "Rien envoyé", vbInformation, "AUCUNE RELANCE": Exit Sub
noms = Right(noms, Len(noms) - 1)
Set OutApp = CreateObject("outlook.application")
Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = "DA-COSTA"
        .Cc = noms
       ' .Attachments.Add (rep & "\" & NomFic)
        .Subject = Feuil2.[D2] 'le message
        .Body = "RELANCE CONTROL" 'le titre
        .Display
        .Send
    End With
End Sub
 

LuanaDDC

XLDnaute Junior
Bonjour,

Merci beaucoup pour votre retour ! Je vais essayer.

J'ai une question, s'il vous plait, le code prends bien en compte les adresses mails qui seront mentionnés dans ma colonne H ? Par ailleurs, concernant la relance +7 et +15, il faut que je rajoute mes adresses mails supplémentaires dans .To ? Ou vous me conseillez de les écrire dans une cellule masqué et prendre la colonne ?

En vous remerciant encore une fois !

Bonne journée.
 

youky(BJ)

XLDnaute Barbatruc
Bonjour
Le mieux est de créer une colonne supplémentaire pour y mettre la 2ème adresse(même masquée)
Voici un code qui si la diff est plus grande de 0 don 7 ou 15 on prend l'adresse en col J sinon en col H
Bruno
VB:
Sub EnvoiMail()
Dim OutApp As Object
Dim OutMail As Object
For lig = 2 To [C65000].End(3).Row
n = Date - Cells(lig, 6)
If n = -15 Or n = -7 Or n = 0 Or n = 7 Or n = 15 Then
'''''''''si n >0 prend adresse en col J sinon en col H
noms=iif(n>0,noms & ";" & cells(lig,10),noms & ";" & cells(lig,8))
'noms = noms & ";" & Cells(lig, 8)
Cells(lig, 9) = Date
End If
Next
If noms = "" Then MsgBox "Rien envoyé", vbInformation, "AUCUNE RELANCE": Exit Sub
noms = Right(noms, Len(noms) - 1)
Set OutApp = CreateObject("outlook.application")
Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = "DA-COSTA"   'nom de la boite
        .Cc = noms
       ' .Attachments.Add (rep & "\" & NomFic)
        .Subject = Feuil2.[D2] 'le message à adapter
        .Body = "RELANCE CONTROL" 'le titre
        .Display
        .Send
    End With
End Sub
 

Discussions similaires

Réponses
6
Affichages
268
Réponses
1
Affichages
119

Statistiques des forums

Discussions
311 709
Messages
2 081 774
Membres
101 816
dernier inscrit
Jfrcs