macros et vba excel envoi de mails multiples

J'ai lu cette discussion.

Est-il possible de faire des envois multiples? J'essaye de le faire mais toujours des erreurs du genre l'élément a été supprimé ou déplacé. (bug sur le destinaire .to ou .recipients.add) . voici le code que j'utilise

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
Private Sub CommandButton1_Click()
  Dim Sujet As String
  Dim Dest As String
  Dim mes As String
  Dim i As Integer
  Dim Ol As Outlook.Application
  Dim MyItem As Outlook.MailItem
  Sujet = "Demande de fiche"
  Set Ol = CreateObject("Outlook.Application")
  Set MyItem = Ol.CreateItem(olMailItem)
  For i = 2 To 100
    If Sheets(1).Cells(i, 1) = "" Then
      MsgBox "Fin de liste les mails ont étés envoyés"
      Exit Sub
    End If
    Dest = Sheets(1).Cells(i, 4)    'du genre "mail@mail.com" dans la cellule
    mes = "Bonjour pouvez-vous nous envoyer la fiche N°*:" & Sheets(1).Cells(i, 1)
    With MyItem
       .To = Dest 
       '.Recipients.Add Dest
       .Body = mes
       .CC = "xxx@xxx.com"
     '  .CC = "xxx@xxx.com"
       .Subject = Sujet
       .OriginatorDeliveryReportRequested = False
       .ReadReceiptRequested = False
       .Send
   End With
  Next i
End Sub

J'ai un bug à la 2ème itération.Un seul mail est envoyé au 1er destinaire.

Merci d'avance