Microsoft 365 Envoie mail automatique

vby

XLDnaute Nouveau
Bonsoir cher Forum

Je voudrais que vous m'appuyez à corriger ce code VBA. JE voudrais que si la valeur des cellules AB3 à AB100 est comprise entre 0 et 30 qu'il envoie un mail automatique à l'émail figurant sur la colonne Z en mettant en objet le nom de la colonne H. pour le corps du message il commencera par Bonjour + le nom de la cellule à F.

Exemple1: si AB4 = 27, qu'il envoie un mail à Z4 avec comme :

Objet Mettre à jour date fin contrat H4
et comme corps du message : Bonjour cher.e F4,
Juste un petit rappel que le contrat H4 prend fin à K4.
Cordialement

Exemple1: si AB30 = 1, qu'il envoie un mail à Z30 avec comme :

Objet Mettre à jour date fin contrat H30
et comme corps du message : Bonjour cher.e F30,
Juste un petit rappel que le contrat H30 prend fin à K30.
Cordialement

Je voudrais que cela se produit qu'une seule fois par jour lors de la première ouverture du fichier. De plus si la cellule à la colonne AB est comprise entre 0 et 30 qu'il colorie en rouge la cellule K correspondante.

Merci de votre précieuse aide !

Ci dessous le code j'avais entamé :

Private Sub Workbook_Open()

Dim OutApp As Object
Dim OutMail As Object
Dim strBody As String
Dim toEmail As String
Dim i As Integer

For i = 3 To 54
If Range("AB" & i).Value = 0 Then
If Not IsEmpty(Range("Z" & i).Value) Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
toEmail = Range("Z" & i).Value

strBody = "Bonjour, <br><br>" _
& "La valeur de la cellule AB" & i & " est égale à 0. <br><br>" _
& "Cordialement, <br>" _
& "Votre nom"

On Error Resume Next

With OutMail
.To = toEmail
.CC = ""
.BCC = ""
.Subject = "Sujet de l'e-mail"
.HTMLBody = strBody
.Send
End With

On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End If
End If
Next i

End Sub
 

Pièces jointes

  • xlm master25.xlsm
    40.1 KB · Affichages: 5

vby

XLDnaute Nouveau
@Phil69970
il affiche une notification à l'ouverture mais n'envoie pas de mail. De plus il signale juste une cellule qui une valeur entre 0 et 30, alors pour l'exemple il y a 3 cellules concernées.

Ci joint les captures
 

Pièces jointes

  • Screenshot 2023-05-04 191647.png
    Screenshot 2023-05-04 191647.png
    102.9 KB · Affichages: 25
  • Screenshot 2023-05-04 191633.png
    Screenshot 2023-05-04 191633.png
    13.7 KB · Affichages: 22

Phil69970

XLDnaute Barbatruc
@vby


1683228519044.png


Le message c'est pour mes tests et que tu vois ce qui va être dans le corps du mail
L'instruction Stop j'ai oublié de l'enlever c'est pour stopper le code avant l'envoi du mail. Tu peux la supprimer

@Phil69970
 

vby

XLDnaute Nouveau
@Phil69970

Merci ca marche. Mais est ce possible qu'il envoie automatiquement les mails sans que je les consulte ?

Est ce possible aussi pour le corps du message qu'il va à la ligne pour plus de visibilité par exemple il affiche ca:

Bonjour cher.e CB,Juste un petit rappel que le contrat A6 prend fin à 01/06/2023Cordialement,

or moi je veux qu'il l'affiche comme ca :

Bonjour cher.e CB,

Juste un petit rappel que le contrat A6 prend fin à 01/06/2023

Cordialement,
 

vby

XLDnaute Nouveau
Merci beaucoup @Phil69970

Ca marche à merveille!

J'ai retravaillé le code comme suit :

VB:
Private Sub Workbook_Open()
    Dim OutApp As Object, OutMail As Object
    Dim strBody$, toEmail$, ccEmail$, i%
    
    'Boucle sur les lignes
    For i = 3 To 200
        'Vérifie que la cellule XER contient une valeur comprise entre 0 et 30 et que la cellule G n'est pas vide
        If Range("XER" & i).Value >= 0 And Range("XER" & i).Value <= 30 And Not IsEmpty(Range("G" & i).Value) Then
            
            'Affiche un message box avec les informations nécessaires
            MsgBox "Cher.e " & Range("F" & i) & "," & vbCrLf & _
                "Juste un petit rappel que le contrat " & Range("J" & i) & " prend fin au " & Range("M" & i) & vbCrLf & vbCrLf & _
                "Cordialement, " & vbCrLf & vbCrLf & _
                " Consulter les lignes colorées en rouge svp"
            
            'Envoie l'e-mail
            On Error Resume Next
            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)
            toEmail = Range("G" & i).Value
            ccEmail = Range("H" & i).Value
            
            strBody = "Bonjour cher.e " & Range("F" & i) & "," & vbCrLf & _
                "Juste un petit rappel que le contrat " & Range("J" & i) & " prend fin au " & Range("M" & i) & vbCrLf & vbCrLf & _
                "Cordialement, " & vbCrLf & vbCrLf & _
                "Ceci est un message automatique merci de ne pas y répondre"
            
            With OutMail
                .To = toEmail
                .CC = ccEmail
                .Subject = Range("J" & i) & ": Mettre à jour date fin contrat dans la Masterlist 2023"
                .Body = strBody
                .Send
            End With
            
            Set OutMail = Nothing: Set OutApp = Nothing
            
            'Colorie en rouge les lignes où la valeur d'XER est comprise entre 0 et 30
              
            If Range("XER" & i).Value >= 0 And Range("XER" & i).Value <= 30 Then
                Range("A" & i & ":AAZ" & i).Interior.Color = vbRed
            End If
        End If
            
    Next i
    
    Sheets("MasterList 2023").Protect password:="master"
    
End Sub

Seulement je n'arrive à reproduire qu'il envoie le mail juste lors de la première ouverture de la journée et de manière journalière !
Encore merci à toi !
 

vby

XLDnaute Nouveau
@Phil69970
Oui j'ai essayé et il le fait bien.
Mais j'ai essayé d'adapter le code sur le vrai fichier qui a des infos personnelles

Je vous partage le fichier d'adaptation dont j'ai essayé de retravaillé le à l'aide Chat Gpt :

VB:
Private Sub Workbook_Open()
    Dim OutApp As Object, OutMail As Object
    Dim strBody$, toEmail$, ccEmail$, i%
    
    'Boucle sur les lignes
    For i = 3 To 200
        'Vérifie que la cellule XER contient une valeur comprise entre 0 et 30 et que la cellule G n'est pas vide
        If Range("XER" & i).Value >= 0 And Range("XER" & i).Value <= 30 And Not IsEmpty(Range("G" & i).Value) Then
            
            'Affiche un message box avec les informations nécessaires
            MsgBox "Cher.e " & Range("F" & i) & "," & vbCrLf & _
                "Juste un petit rappel que le contrat " & Range("J" & i) & " prend fin au " & Range("M" & i) & vbCrLf & vbCrLf & _
                "Cordialement, " & vbCrLf & vbCrLf & _
                " Consulter les lignes colorées en rouge svp"
            
            'Envoie l'e-mail
            On Error Resume Next
            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)
            toEmail = Range("G" & i).Value
            ccEmail = Range("H" & i).Value
            
            strBody = "Bonjour cher.e " & Range("F" & i) & "," & vbCrLf & _
                "Juste un petit rappel que le contrat " & Range("J" & i) & " prend fin au " & Range("M" & i) & vbCrLf & vbCrLf & _
                "Cordialement, " & vbCrLf & vbCrLf & _
                "Ceci est un message automatique merci de ne pas y répondre"
            
            With OutMail
                .To = toEmail
                .CC = ccEmail
                .Subject = Range("J" & i) & ": Mettre à jour date fin contrat dans la Masterlist 2023"
                .Body = strBody
                .Send
            End With
            
            Set OutMail = Nothing: Set OutApp = Nothing
            
            'Colorie en rouge les lignes où la valeur d'XER est comprise entre 0 et 30
              
            If Range("XER" & i).Value >= 0 And Range("XER" & i).Value <= 30 Then
                Range("A" & i & ":AAZ" & i).Interior.Color = vbRed
            End If
        End If
            
    Next i
    
    Sheets("MasterList 2023").Protect password:="master"
    
End Sub
 

Pièces jointes

  • Masterlist 2023 - Copie - Copie.xlsm
    119.1 KB · Affichages: 6

Phil69970

XLDnaute Barbatruc
@vby

Quelques remarques :

Tu n'as pas compris mon code qui permet d'envoyer 1 mail à l'ouverture et 1 seul par jour o_O

Pourtant j'avais bien pris soin d'écrire

==> Ne pas déplacer les cellules Z1 et AA1

Si j'ai écris cela c'est pas pour le fun !!!

Dans ton fichier
du post #1 la cellule Z1 contient la date du jour je m'en sers pour comparer avec la date que j'ai mis en AA1 si il y une différence c'est que nous avons changé de jour et donc je peux lancé la macro avec les mails ET si c'est la même date c'est donc le même jour .... CQFD

Dans ton code du post #9 et 11 tout cela à disparu !!!!
==> Donc c'est un normal que cela ne fonctionne plus !!!

Bien sur tu peux choisir d'autres cellules et adapter le code en conséquence...

Autre chose si en fin de macro tu mets un MDP je m'attends à voir en début de macro une ligne de code pour enlever le MDP

Sheets("MasterList 2023").Protect password:="master"
Et sauf erreur de ma part j'ai rien vu de tel !!!

De plus quand on fournit un fichier il doit être représentatif
C'est quoi représentatif ?

- représentatif, même organisation des lignes et des colonnes, mêmes libellés, mêmes noms de feuilles...
- anonymisé, pas de données personnelles réelles tels nom, n° sécu, adresse ... remplacé par Nom1, Nom2 etc ....
- simplifié, une quinzaine de lignes reproduisant l'ensemble des différents cas envisageables (Avec le résultat souhaité éventuellement)

*Préciser l'ordre de grandeur des lignes à traiter, exemple mon fichier comporte 1 000 lignes ou bien 200 000 lignes ==> la méthodologie peut être différents.

Une demande claire donne très souvent une réponse rapide et qui correspond au mieux à la demande.

Si cela fonctionne sur le fichier fourni et pas sur le vrai fichier c'est qu'il n'est en rien représentatif ou que tu n'as pas su transposer ce qui devrait être un simple copier coller du code.

Arriveras tu à faire la macro sur ton fichier avec toutes les infos que je t’ai donné ?
Sinon je te le ferais .... :oops:

Merci de ton retour

@Phil69970
 
Dernière édition:

Statistiques des forums

Discussions
313 225
Messages
2 096 347
Membres
106 583
dernier inscrit
yasinus