Bonjour à Tous !!

Je tente de réaliser une macro qui, à partir d'une base de données Excel, me permettrait d'envoyer un fichier .PDF personnalisé à chaque destinataire mais avec un corps de mail identique et qui serait le contenu de cellules ( pour ne pas avoir a le mettre dans le code et le changer facilement).

Grace à quelques blocs VBA trouvés sur différents forums j'ai réussi à éditer une macro qui semble fonctionner dans l'ensemble ( merci à tous car developpez.net m'aide beaucoup !! ) mais je n'arrive pas à mes fins en ce qui concerne le corps du mail...

En bref, la macro rédige des mails à mes destinataires ( A, B, C );
La macro affecte à chaque destinataire/mail un ficher .PDF ( A.pdf, B.pdf, C.pdf ) qui est rangé dans un dossier que l'utilisateur peut trouver via une MsgBox
Le corps du mail se trouve dans l'onglet "Courrier" et la macro le trouve bien mais lorsque je la lance le destinataire A à le corps de mail correct, le destinataire B à 2 fois le corps de mail , le destinataire C à 3 fois le corps de mail , Etc ...

J'arrive à la limite de mes compétence et je me permets de solliciter votre aide sur le sujet; il y a peut être d'autres erreurs dans le code mais pourriez vous s'il vous plait m'aider ???

Code : Sélectionner tout - Visualiser dans une fenêtre à part
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
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
 
Sub Lancement_Diffusion()
 
    Dim ret As Integer
    ret = MsgBox("Cette option lance la diffusion des courriers" & vbNewLine & "Etes vous certain de vouloir poursuivre", _
            vbYesNo + vbExclamation + vbDefaultButton3, "Demande de confirmation")
    If ret = vbNo Then
    Exit Sub
    Else
 
Application.ScreenUpdating = False
 
Sheets("Liste épurée").Activate
 
    Dim dossier As Object, chemin$
    Set dossier = Application.FileDialog(msoFileDialogFolderPicker)
 
        If dossier.Show = -1 Then
            chemin = dossier.SelectedItems(1)
            'MsgBox chemin
        Else: Exit Sub
        End If
 
    Dim OutApp As Object
    Dim OutMail As Object
    Dim signature As String
    Dim Destinataire As String
    Dim cell As Range
 
    Set OutApp = CreateObject("Outlook.Application")
 
    On Error GoTo cleanup
 
        For Each cell In ThisWorkbook.Worksheets("Liste épurée").Columns("D").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" Then
 
        Set OutMail = OutApp.CreateItem(0)
 
        With OutMail
            .Display
        End With
 
        signature = OutMail.htmlbody
 
    On Error Resume Next
 
        Dim ws As Worksheet
        Set ws = Worksheets("Courrier")
 
        btm = ws.Cells(Rows.Count, 2).End(xlUp).Row
        For i = 5 To btm
        myvalue = myvalue & "<br>" & ws.Cells(i, 2).Value
        Next i
 
            With OutMail
                .To = cell.Value
                .Subject = ws.Range("B3").Value
                .htmlbody = myvalue & _
                signature
                .Attachments.Add (chemin & "\" & Cells(cell.Row, "A").Value & ".pdf")
                .Display  'mettre .Send pour envoyer ou .Display pour simplement créer des mails
 
            End With
 
            On Error GoTo 0
 
            Set OutMail = Nothing
 
        End If
 
        Next cell
 
cleanup:
 
    Set OutApp = Nothing
 
Application.ScreenUpdating = True
 
Sheets("Courrier").Activate
 
    End If
 
    MsgBox "Courrier(s) envoyé(s)", vbInformation
 
End Sub[ATTACH]632402[/ATTACH]