Sub EnvoiEmails()
Dim xRg As Range
Dim xRgEach As Range
Dim xRgVal As String
Dim xAddress As String
Dim xOutApp As Object
Dim xMailOut As Object
On Error Resume Next
xAddress = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Sélection adresse(s) email(s)", "Envoi email(s)", xAddress, , , , , 8)
If xRg Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set xOutApp = CreateObject("Outlook.Application")
Set xRg = xRg.SpecialCells(xlCellTypeConstants, xlTextValues)
For Each xRgEach In xRg
xRgVal = xRgEach.Value
sujet = Range("d" & xRgEach.Row) ' modif
If xRgVal Like "?*@?*.?*" Then
Set xMailOut = xOutApp.CreateItem(olMailItem)
With xMailOut
.To = xRgVal
.Subject = sujet ' et ici
.Body = "Cher Client, " _
& vbNewLine & vbNewLine & _
"BlaBlaBla....................." _
& vbNewLine & _
"Sincères salutations" _
& vbNewLine & _
"Signature" _
.Display
'.Send
End With
End If
Next
Set xMailOut = Nothing
Set xOutApp = Nothing
Application.ScreenUpdating = True
End Sub