Problème VBA envoie mail

Bonjour,

Depuis le passage sous office 365, je n'arrive plus à envoyer de mail à un seul dentinaire. Avant j'arrivais à envoyer au 4 personnes qui sont renseignées des les cellules. Quelqu'un à une idée ? Merci d'avance

Sub Send_Mails()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("nom du fichier")
Dim i As Integer

Dim OA As Object
Dim msg As Object

Set OA = CreateObject("outlook.application")

Dim Dp As Integer
Dp = Application.CountA(sh.Range("A:A"))

For i = 2 To Dp
Set msg = OA.createitem(0)


msg.To = sh.Range("D" & i).Value
msg.To = sh.Range("A" & i).Value
msg.To = sh.Range("B" & i).Value
msg.To = sh.Range("C" & i).Value

msg.Subject = sh.Range("E" & i).Value

msg.body = sh.Range("F" & i).Value

If sh.Range("E" & i).Value <> "" Then
msg.attachments.Add sh.Range("G" & i).Value
msg.attachments.Add sh.Range("H" & i).Value

End If


msg.send

Next i
'message de fin

MsgBox "les mails sont envoyés avec succès"

End Sub

Bonjour,

Le mail est envoyé à qu'un seul destinataire ou vous n'arrivez plus à l'envoyer ? On ne comprend pas bien.

Normalement, les destinataires sont séparés par des ";". Dans votre cas, seul le dernier est conservé. Voici un essai d'adaptation :

Sub Send_Mails()
Dim OA as object, msg as object, sh As Worksheet, i%, Dp%
Set sh = ThisWorkbook.Sheets("nom du fichier")
Set OA = CreateObject("outlook.application")
Dp = Application.CountA(sh.Range("A:A"))
For i = 2 To Dp
    Set msg = OA.createitem(0)
    with msg
        .To = join(application.transpose(application.transpose(sh.Range("A:D").rows(i).Value)), ";")
        .body = sh.Range("F" & i).Value
        If sh.Range("E" & i).Value <> "" Then
            .Subject = sh.Range("E" & i).Value 'penser à un sujet par défaut
            .attachments.Add sh.Range("G" & i).Value
            .attachments.Add sh.Range("H" & i).Value
        End If
        .send
    end with
Next i
'MsgBox "les mails sont envoyés avec succès"
End Sub

Cdlt,

Bonjour,

Merci, ta macro marche à merveille !!!

Bonne journée