Sub un_seul_email()
Dim LIG As Integer, NOM, CORPS, DESTI, COPIE, TITRE As String
Application.ScreenUpdating = False
' définition du titre et du corps du message
Sheets("Paramétrage").Visible = True
Sheets("Paramétrage").Select
TITRE = Columns("A:A").Find(what:="Titre :").Offset(0, 1).Value
Columns("A:A").Find(what:="Corps du message :").Activate
Do While ActiveCell.Value <> "Destinataires principaux"
CORPS = CORPS & "<br>" & ActiveCell.Offset(0, 1).Value
CORPS = "<font style='font-family: Times New Roman ;font-size: 12pt ;' color=black>" & CORPS & "</font>"
ActiveCell.Offset(1, 0).Select
Loop
Columns("C:C").Find(what:="Destinataire en copie:").Offset(1, 0).Activate
Do While IsEmpty(ActiveCell) = False
COPIE = COPIE & ";" & ActiveCell.Value
ActiveCell.Offset(1, 0).Select
Loop
'Sheets("Paramétrage").Visible = False
'définiton des destinataires
Sheets("Imputation").Select
Cells.Find("Envoyer mail?").Offset(1, 0).Activate
LIG = Cells(65536, ActiveCell.Column).End(xlUp).Row
For i = 1 To LIG
If ActiveCell = "envoyer mail" Then DESTI = DESTI & ";" & Application.WorksheetFunction.VLookup(ActiveCell.Offset(0, -6).Value, Sheets("Paramétrage").Range("A:B"), 2, False)
ActiveCell.Offset(1, 0).Select
Next
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(olMailItem)
On Error Resume Next
With OutMail
.to = DESTI
.CC = COPIE
.Subject = TITRE
.HTMLBody = CORPS
'.Save
End With
OutMail.Display
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub