XL 2016 Envoi d'un mail sous conditions avec Outlook

[TechnologyNewStore]

Bonjour à tous,

Je cherche depuis quelques jours à faire l'envoi d'un mail groupé sous conditions. Voici ma configuration :
Je dispose d'une Feuil1 avec une liste de nom en colonne B à partir de la ligne 18. Sur cette feuille, les colonnes C et E seront complétées par des informations avec du texte (type "OK"). Les colonnes C et E ne pourront pas accueillir toutes les deux du texte sur une même ligne (soit dans C, soit dans E).
Si les colonnes C et E sont vides, il faudrait qu'un mail soit envoyé aux noms associés lorsque les deux colonnes (en même temps) grâce aux mails listés en Feuil2.
Sur la Feuil2, on retrouve la liste des noms en colonne B (à partir de la ligne 2) et les mails associés aux noms en colonne E (à partir de la ligne 2).

Je pense qu'il faut coder cela avec une boucle "For Each" et faire une comparaison entre les noms de la Feuil1 et de la Feuil2 lorsque les conditions sur la Feuil1 sont respectées mais je n'ai pas trouvé comment faire.

Pour information, le listing des noms sera variable avec le temps (j'ai vu des instructions dans des boucles qui pouvaient aller jusqu'à la dernière ligne au lieu de mettre un grand nombre).

En première étape, j'ai réussi à lancer mon "Button1" qui envoi un mail à tout le monde (sans conditions) :

Private Sub Button1_Click()
Dim LeMail As Variant
Dim adresses As Range
Dim dest As String

For Each adresses In Sheets("Feuil2").Range("E2:E100")
dest = dest + adresses.Value + ";"
Next adresses

Set LeMail = CreateObject("Outlook.Application") 'Création d'un objet Outlook
With LeMail.CreateItem(olMailItem) 'Informe le programme que nous voulons envoyer un mail
    .Subject = "Rappel"
    .To = dest
    .Body = "Ceci est un mail de rappel généré automatiquement."
    .Display 'Afficher le mail

End With

End Sub

Ensuite, j'ai tenté ce code avec conditions mais sans succès :

Private Sub Button1_Click()
Dim dest As String
Dim i,j As Byte
Dim adresses As Range
For i = 18 To 100
For j = 2 To 100
If ThisWorkbook.Worksheets("Feuil1").Cells(i, 3) & Cells(i, 5).Value = "" Then
For Each adresses In Sheets("Feuil2").Cells(j, 5)
dest = dest + adresses.Value + ";"
Next adresses

Set ObjOutlook = New Outlook.Application
Set oBjMail = ObjOutlook.CreateItem(olItem)

With oBjMail
    .Subject = "Rappel"
    .To = dest
    .Body = "Ceci est un mail de rappel généré automatiquement."
    .Display 'Afficher le mail

End With

End If
Next
End Sub

Auriez-vous des pistes à me donner svp ?

Merci par avance.

Je vous remercie d'avance.

 

[fanch55]

Salut,
Une méthode entre autres

Option Explicit
Private Sub Button1_Click()
Dim ObjOutlook      As Object
Dim ObjMail         As Object
Dim Outlook_Was_Active  As Boolean

    On Error Resume Next
        Set ObjOutlook = GetObject(, "Outlook.Application")
        Outlook_Was_Active = Not ObjOutlook Is Nothing
        If Not Outlook_Was_Active Then Set ObjOutlook = CreateObject("Outlook.Application")
    On Error GoTo 0
    
    Set ObjMail = ObjOutlook.CreateItem(0)
        With ObjMail
            .Subject = "Rappel"
            .To = Dest
            .Body = "Ceci est un mail de rappel généré automatiquement."
            .Display 'Afficher le mail
        End With
    Set ObjMail = Nothing
    
    If Not Outlook_Was_Active Then ObjOutlook.Quit
    Set ObjOutlook = Nothing
    
End Sub

Function Dest() As String
Dim Lr      As Long
Dim Ligne   As Range
Dim RFind   As Range
    
    Lr = ThisWorkbook.Worksheets("Feuil1").Cells(ThisWorkbook.Worksheets("Feuil1").Rows.Count, "B").End(xlUp).Row
    For Each Ligne In ThisWorkbook.Worksheets("Feuil1").Range("B18:E" & Lr).Rows
        If Ligne.Cells(2) & Ligne.Cells(4) = "" Then
            Set RFind = Worksheets("Feuil2").[B2:E9].Find(Ligne.Cells(1))
                If Not RFind Is Nothing _
                Then Dest = IIf(Dest = "", "", Dest & ";") & RFind.Offset(, 3)
            Set RFind = Nothing
        End If
    Next
    
End Function

 

[fanch55]

Sinon une autre alternative si possible de mettre une formule dans une autre colonne de la table :

Le code serait alors:

Option Explicit
Private Sub Button1_Click()
Dim ObjOutlook      As Object
Dim ObjMail         As Object
Dim Outlook_Was_Active  As Boolean

    On Error Resume Next
        Set ObjOutlook = GetObject(, "Outlook.Application")
        Outlook_Was_Active = Not ObjOutlook Is Nothing
        If Not Outlook_Was_Active Then Set ObjOutlook = CreateObject("Outlook.Application")
    On Error GoTo 0
    
    Set ObjMail = ObjOutlook.CreateItem(0)
        With ObjMail
            .Subject = "Rappel"
            .To = Replace(Application.Trim(Join(Application.Transpose(ActiveSheet.[F18:F26]))), " ", ";")
            .Body = "Ceci est un mail de rappel généré automatiquement."
            .Display 'Afficher le mail
        End With
    Set ObjMail = Nothing
    
    If Not Outlook_Was_Active Then ObjOutlook.Quit
    Set ObjOutlook = Nothing
    
End Sub

 

[TechnologyNewStore]

Salut,
Une méthode entre autres

Option Explicit
Private Sub Button1_Click()
Dim ObjOutlook      As Object
Dim ObjMail         As Object
Dim Outlook_Was_Active  As Boolean

    On Error Resume Next
        Set ObjOutlook = GetObject(, "Outlook.Application")
        Outlook_Was_Active = Not ObjOutlook Is Nothing
        If Not Outlook_Was_Active Then Set ObjOutlook = CreateObject("Outlook.Application")
    On Error GoTo 0
   
    Set ObjMail = ObjOutlook.CreateItem(0)
        With ObjMail
            .Subject = "Rappel"
            .To = Dest
            .Body = "Ceci est un mail de rappel généré automatiquement."
            .Display 'Afficher le mail
        End With
    Set ObjMail = Nothing
   
    If Not Outlook_Was_Active Then ObjOutlook.Quit
    Set ObjOutlook = Nothing
   
End Sub

Function Dest() As String
Dim Lr      As Long
Dim Ligne   As Range
Dim RFind   As Range
   
    Lr = ThisWorkbook.Worksheets("Feuil1").Cells(ThisWorkbook.Worksheets("Feuil1").Rows.Count, "B").End(xlUp).Row
    For Each Ligne In ThisWorkbook.Worksheets("Feuil1").Range("B18:E" & Lr).Rows
        If Ligne.Cells(2) & Ligne.Cells(4) = "" Then
            Set RFind = Worksheets("Feuil2").[B2:E9].Find(Ligne.Cells(1))
                If Not RFind Is Nothing _
                Then Dest = IIf(Dest = "", "", Dest & ";") & RFind.Offset(, 3)
            Set RFind = Nothing
        End If
    Next
   
End Function

Merci pour cette réponse rapide fanch55.

J'essaie de décrypter le code et m'intérroge sur :
- Lr : variable pour décrire la "left row" ?
-

Set RFind = Worksheets("Feuil2").[B2:E9].Find(Ligne.Cells(1))

: y'a t-il moyen de faire plus généraliste en demandant de chercher entre la cellule B2 et la dernière cellule remplie de la colonne E ?
- Est-ce que ce code marcherai avec les noms dans le désordre alphabétique (aléatoire) en Feuil1 et classés dans l'ordre alphabétique en Feuil2 ?