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
|
Option Explicit
Type donnee
adressmail As String
texte As String
sujetmessage As String
End Type
' j'ai mis 500 au cas ou tu aurais 500 mail a envoyer tu peut augmenter a ton cas
Sub mailing()
Dim destinataire(500) As donnee
Dim i As Long, e As Long, d As Variant, cel As Range, elem As Variant, c As Range, Col As Long
Dim firstAddress As String, a As Long
'on va lister la plage de nom en colonne A dans un dictionnaire pour en suprimer les doublons
Set d = CreateObject("Scripting.Dictionary")
For Each cel In Sheets("instruction mailing").Range("a2:a" & Range("a" & Rows.Count).End(xlUp).Row) 'dans la plage a1 a10 a toi d'adapter la tienne
d.Item(cel.Value) = ""
Next cel
'maintenant que l'on a plus de doublons
'on boucle sur tout les elements du dictionnaire
For Each elem In d
'dans la colonne a on va chercher tout les ocurence de chaque elements du dictionnaire
With Sheets("instruction mailing").Range("a2:a" & Range("a" & Rows.Count).End(xlUp).Row)
Set c = .Find(elem, LookIn:=xlValues) 'on cherche la valeur de elem
If Not c Is Nothing Then 'si il existe
firstAddress = c.Address
i = i + 1
destinataire(i).adressmail = elem 'on prend l'element du dictionnaire pour le destinataire
destinataire(i).texte = .Cells(c.Row, 3) & vbCrLf & .Cells(c.Row, 4)
Do
'on boucle sur toute les cellule pour voir si on ne trouve pas un nom identique jusque qu'a qu'on soit arriver a la premiere adresse trouvée
destinataire(i).sujetmessage = c.Offset(0, 1)
For Col = 5 To 15 ' boucle sur les colonnes "C" a "Q" pour récupérer le texte
If Cells(c.Row, Col) <> "" Then 'on la prend si elle n'est pas vide ca evite des sauts de lignes pour rien
destinataire(i).texte = destinataire(i).texte & vbCrLf & Cells(c.Row, Col) ' et on inscrit dans le destinataire .texte la valeur de la cellule a droite des noms
End If
Next
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
destinataire(i).texte = destinataire(i).texte & vbCrLf & .Cells(c.Row, 16) & vbCrLf & .Cells(c.Row, 17)
End If
End With
Next
'un essaie dans un message box dans une boucle
For e = 1 To i
' MsgBox destinataire(e).adressmail & vbCrLf & vbCrLf & destinataire(e).texte
'on appelle la fonction envoie_message avec les deux arguments destnataires et le corps du message
envoie_message destinataire(e).adressmail, destinataire(e).sujetmessage, destinataire(e).texte
'TRADUCTION envoie_message destinataire , sujet ,corps du message
Next
'je n'ai pas tester la fonction envoie_message car je ne me sert pas d'outlook je te laisse le soin de la rectifier si besoin est
End Sub
Function envoie_message(dest As String, sujet, texto As String)
Dim MonOutlook As Object
Set MonOutlook = CreateObject("Outlook.Application")
Set monmessage = MonOutlook.CreateItem(0)
monmessage.SentOnBehalfOfName = expediteur
monmessage.display
monmessage.To = dest
monmessage.Cc = "xxxx"
monmessage.Subject = sujet
monmessage.body = texto
monmessage.send
End Function |
