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
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
| Sub CreationFichierExcelFournisseurPlusMail()
'Début de la déclaration des variables
Dim objMaPlage As Range
Dim cell As Range
Dim colCollectionPass As Collection
Dim I As Long
Dim compteur, compteurmail, compteurfichier, compteurtotal As Integer
Dim LastRow, LastRow2 As Long
Dim FichierSource As Workbook
Dim FichierDestination As Workbook
Dim Temp As String
Dim nom As String
Dim Fichier As String
Dim ol As New Outlook.Application
Dim olmail As MailItem
Dim corps As String
Dim MaRech As Range
Dim Fournisseur As String
Dim MailFournisseur, MailFournisseurCC As String
Dim Reponse As Long
'Fin de la déclaration des variables
'--------------------------------------------------------------------------
'Début des actions et demande de confirmation avant traitement des informations
Reponse = MsgBox("Voulez vous continuer la création des fichiers et l'envoi par e-mail ?", vbQuestion + vbYesNo, "Demande de confirmation")
If Reponse = vbYes Then
'Début de l'initialisation des variables
'Set ol = New Outlook.Application
'Set olmail = ol.CreateItem(olMailItem)
compteurmail = 0
compteurfichier = 0
compteurtotal = 0
Set objMaPlage = Range(Range("B" & Rows.Count).End(xlUp), Cells(5, 2)).SpecialCells(xlCellTypeVisible)
objMaPlage.Select 'inutile, pour visualisation seulement
Set colCollectionPass = New Collection
On Error Resume Next
For Each cell In objMaPlage
colCollectionPass.Add cell, CStr(cell)
Next cell
For I = 2 To colCollectionPass.Count 'on élimine le titre en 1...ce qui serait plus lour avec un for each
'Debug.Print colCollectionPass(I) 'résultat voulu à employer sous la forme désirée.
'MsgBox (colCollectionPass(I))
Next I
'Début de la boucle pour faire varier le filtre
For compteur = 1 To colCollectionPass.Count
Set ol = New Outlook.Application 'Test evi
Set olmail = ol.CreateItem(olMailItem) 'Test evi
Selection.AutoFilter Field:=2, Criteria1:=colCollectionPass(compteur)
Sheets("Sheet2").Select
LastRow2 = Cells(Rows.Count, "A").End(xlUp).Row
Rows("1:" & LastRow).Select
Selection.Delete Shift:=xlUp
Sheets("Les données SAP").Select
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
Range("B5:X" & LastRow).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
Columns("A:M").Select
Columns("A:M").EntireColumn.AutoFit
Range("A1").Select
Set FichierSource = ActiveWorkbook
ActiveSheet.Copy 'Copie de la totalité de l'onglet actif dans le fichier source
Set FichierDestination = ActiveWorkbook
'Début des opérations permettant la préparation du fichier excel temporaire avant envois par e-mail
nom = Range("A2")
Temp = ThisWorkbook.Path & Application.PathSeparator & "ZEvi Fichier Excel" & Application.PathSeparator & nom & ".xls" 'Attribution du nom du fichier temporaire et mémorisation du chemin complet de ce dernier
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
FichierDestination.SaveAs Temp 'Sauvegarde (création) du fichier temporaire dans le même répertoire que le fichier d'origine
Fichier = FichierDestination.Path & Application.PathSeparator & FichierDestination.Name '
FichierDestination.Close 'Fermeture du fichier précédemment sauvegardé
Application.DisplayAlerts = True
'Fin des opérations permettant la préparation du fichier excel temporaire avant envois par e-mail
'--------------------------------------------------------------------------
'Test si il existe une addresse e-mail afin d'envoyer ou pas un e-mail
MailFournisseur = ""
MailFournisseurCC = ""
Fournisseur = nom
Set MaRech = Sheets("Mail").Range("A2:A65000").Find(Fournisseur, LookIn:=xlValues) 'Adapter le nom de la feuille qui contient le tableau
If Not MaRech Is Nothing Then 'Si MaRech n'est pas rien (donc référence trouvée)
MailFournisseur = MaRech.Offset(0, 1) 'Affectation à la variable du contenu de la cellule de droite de celle qui contient la référence
MailFournisseurCC = MaRech.Offset(0, 2)
Else
MailFournisseur = ""
MailFournisseurCC = ""
'MsgBox "La référence n'est pas connue" 'Boite de dialogue indiquant que la référence n'existe pas
End If
If MailFournisseur <> "" Then
'Début de l'envois du mail
'Ecrire ici l'ensemble du texte qui apparaitra dans le mail, vbNewLine permet de mettre en forme le texte et d'aller à la ligne
compteurmail = compteurmail + 1
corps = "Bonjour," & vbNewLine & _
" " & vbNewLine & _
"Vous trouverez ci-joint un fichier correspondant à nos commandes non livrées ou partiellement livrées." & vbNewLine & _
"Je vous demanderai de bien vouloir compléter ce tableau en indiquant les dates cohérentes de livraison pour chaque article de chaque commande." & vbNewLine & _
"D'avance, merci pour votre collaboration," & vbNewLine & _
"Vous en souhaitant bonne réception," & vbNewLine & _
" " & vbNewLine & _
"Cordialement," & vbNewLine & _
" " & vbNewLine & _
" " & vbNewLine & _
" ************************************** " & vbNewLine & _
"Hello," & vbNewLine & _
" " & vbNewLine & _
"Please find enclosed a file with all the open purchase orders, still to be delivered or partially delivered." & vbNewLine & _
" " & vbNewLine & _
"Could you please send it back to me with updating the delivery date?" & vbNewLine & _
" " & vbNewLine & _
"Wishing getting your reply soon." & vbNewLine & _
"Thanks a lot," & vbNewLine & _
" " & vbNewLine & _
"Best regards," & vbNewLine & _
" " & vbNewLine
With olmail
.To = MailFournisseur 'Adresse mail du destinataire
'.CC = MailFournisseurCC 'Personne à mettre en copie du mail
.Subject = "Commandes non livrées ou partiellement livrées ..." 'Titre du mail
.Body = corps 'Descriptif de l'envoi du mail
.Attachments.Add Fichier 'Insertion du fichier en pièce jointe, la variable Fichier contenant le chemin complet du fichier à joindre qui dans le cas présent est "Fichier Temporaire.xls"
.ReturnReceipt 'Pour avoir un accusé de reception
.Display 'Permet l'affichage du mail et évite ensuite d'avoir le message de sécurité lors d'envois d'un e-mail à partir d'excel
End With
SendKeys "^{ENTER}" 'Envoi du mail par les touches Ctrl + Enter "^{Enter}"
Application.ScreenUpdating = True
Kill Fichier 'Effacement du Fichier Temporaire créé lors de cette macro
'Fin de l'envois du mail
'--------------------------------------------------------------------------
Else
compteurfichier = compteurfichier + 1
End If
Application.ScreenUpdating = True
Sheets("Les données SAP").Select
Range("B5").Select
Application.CutCopyMode = False
Next compteur
'Fin des opérations pour lister les noms des fournisseurs sans doublons
'--------------------------------------------------------------------------
Selection.AutoFilter Field:=2
Set objMaPlage = Nothing 'pas obligatoire, mais bonne habitude.
Set colCollectionPass = Nothing
Else
End If
'Fin des actions et demande de confirmation avant traitement des informations
'--------------------------------------------------------------------------
compteurtotal = compteurmail + compteurfichier
MsgBox (compteurmail & " E-mail envoyés" & Chr(10) & _
compteurfichier & " Fichiers Excel créés" & Chr(10) & _
"--------------------------------" & Chr(10) & _
"Soit : " & compteurtotal & " Fournisseurs traités.")
End Sub |
