Synthèse d'un tableau conditionnée + email

Option Explicit

Sub hypertext_email()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim i As Byte

For i = 2 To 8
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
    
    'C'est ici que tu mets le texte. J'ai mis le contenu des
    'colonne A et B en exemple
    strbody = Range("A" & i).Value & "-" & Range("B" & i).Value
    
    On Error Resume Next
    With OutMail
        .To = Range("H" & i).Value
        .CC = ""
        .BCC = ""
        .Subject = "Lien hypertexte"
        .Body = strbody
        '.Display  'Si tu veux afficher le message avant de l'envoyer. Selon moi, dans ton cas, c'est inutile de le prévisionner.
        .Send
    End With
    On Error GoTo 0
    
    Set OutMail = Nothing
    Set OutApp = Nothing
Next i

End Sub

Option Explicit

Sub Test()

Dim Dico As Object, OutApp As Object, OutMail As Object
Dim ValeurRecherche, RangePlage, x, c
Dim firstAddress As String
Dim DL As Long
Dim strbody As String

'*****************************************************************************************************************
'1re étape : On va faire une liste sans doublon des personnes qui sont sur ta liste d'envoi
'*****************************************************************************************************************
Set Dico = CreateObject("Scripting.Dictionary")
DL = Cells(65536, 1).End(xlUp).Row
RangePlage = Range(Cells(2, 1), Cells(DL, 1)).Address
For Each ValeurRecherche In Sheets(ActiveSheet.Name).Range(RangePlage)
    If Not Dico.Exists(ValeurRecherche.Value) And ValeurRecherche.Value <> "" Then
        Dico.Add ValeurRecherche.Value, ValeurRecherche.Value
    End If
Next ValeurRecherche


'*****************************************************************************************************************
'2e étape : Pour chacune de ces personnes, on va aller chercher toute l'information qui lui est destiné et on
        '   va la mettre dans le corps du message.
'*****************************************************************************************************************
For Each x In Dico.Keys() 'Pour chacune des personnes qui se trouve dans notre liste sans doublon
    strbody = ""
    Set c = Range(Cells(1, 1), Cells(DL, 1)).Find(Dico(x), LookIn:=xlValues, lookat:=xlWhole) 'On va aller faire une recherche pour trouver la personne
    If Not c Is Nothing Then 'Si on la trouve, alors ...
    firstAddress = c.Address
    'On va faire une loop pour voir toutes les fois que son nom revient et on va conserver toute l'info dans le corps du texte pour le email
        Do
          strbody = strbody & Range("B" & c.Row).Value & "-" & Range("C" & c.Row).Value & "-" & Range("D" & c.Row).Value & "-" & Range("E" & c.Row).Value & Chr(13)
          Set c = Range(Cells(1, 1), Cells(DL, 1)).FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
    
    'Ensuite on crée le email et on l'envoie
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
    
    On Error Resume Next
    With OutMail
        .To = Range("H" & c.Row).Value
        .CC = ""
        .BCC = ""
        .Subject = "Lien hypertexte"
        .Body = strbody
        '.Display  'Si tu veux afficher le message avant de l'envoyer. Selon moi, dans ton cas, c'est inutile de le prévisionner.
        .Send
    End With
    On Error GoTo 0
    
    Set OutMail = Nothing
    Set OutApp = Nothing
Next

Set Dico = Nothing

End Sub

strbody = strbody & Range("B" & c.Row).Value & "-" & Range("C" & c.Row).Value & "-" & Range("D" & c.Row).Value & "-" & Range("E" & c.Row).Value & Chr(13)

If Cells(c.Row, 7).Value = "" Then strbody = strbody & Range("B" & c.Row).Value & "-" & Range("C" & c.Row).Value & "-" & Range("D" & c.Row).Value & "-" & Range("E" & c.Row).Value & Chr(13)

Sub EnvoyerMail(ByVal AdresseMail As String, ByVal Copie As String, ByVal ObjetMail As String, ByVal CorpsMail As String, ByVal AttachMail As String)
'il vaut mieux avoir ouvrir outlook au préalable
'Dans la barre de tache : outil/reference selectionner :Microsoft Outlook 11.0 library
'envoi de mail automatique
'initialisation des objets
  ' create new Outlook MailItem
  Set objApp = CreateObject("Outlook.Application")
  Set l_Msg = objApp.CreateItem(olMailItem)
'construction du mail
With l_Msg
    .To = AdresseMail
    .BCC = Copie '.BCC si on veut pas que sur le mail soit affiché les copies ou CC si on veut pas cacher
    .Subject = ObjetMail
    If AttachMail <> "" Then
        .Attachments.Add "TOTO.xls"
    End If
    .HTMLBody = CorpsMail
    .Display
End With
'attente de 3 secondes le temps que tous les pcs aient le tps de réagir
Attendre (3)
'simulation d'appui des touches du clavier
SendKeys "%v", True
End Sub
Sub Attendre(Secondes As Integer)
' Cette procédure temporise pendant le nombre
' de secondes qu'on lui transmet en argument
Dim Début As Long, Fin As Long, Chrono As Long
Début = Timer
Fin = Début + Secondes
Do Until Timer >= Fin
    DoEvents
Loop
End Sub