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
| Sub decoupage_et_mail()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With 'pour ne pas avoir de message d'alertes (confirmation a chaque suppression d'onglets / écrasement de fichier existant ...)
' attention pour les phases de test il vaut mieux ne pas le mettre
Dim ObjOutlook As New Outlook.Application
Dim oBjMail
Dim Nom_Fichier As String
Dim i As Integer
Dim t As Integer
Dim a As Integer
'declaration des variables
Windows("Cotations vérif_Final.xlsm").Activate
Range("A1:K13708").Select
ActiveWorkbook.Worksheets("Fiche travail").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Fiche travail").Sort.SortFields.Add Key:=Range( _
"A2:A13708"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Fiche travail").Sort
.SetRange Range("A1:K13708")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Tri du fichier par rapport a la première colonne (ici nom de l'agence)
Chemin = ActiveWorkbook.Path
i = 2
t = i
' deux compteur pour le découpage, t pour le début et i pour la fin
a = 0
' compteur pour le nom d'itération (ici on sait qu'on a 162 agences)
Do While a < 162
t = i 'debut de la zone de découpage
nom = Cells(t, 1) ' on récupère le nom de l'agence
Do While Cells(i, 1) = Cells(i + 1, 1) 'tant que l'agence de ne change pas
i = i + 1 'on incrémente le compteur
Loop
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=Chemin & "\" & nom & ".xlsx"
'on crée et renomme un fichier excel au nom de l'agence
Sheets("Feuil2").Select
ActiveWindow.SelectedSheets.Delete
Application.ScreenUpdating = True
Sheets("Feuil3").Select
ActiveWindow.SelectedSheets.Delete
Application.ScreenUpdating = True
'on supprime les feuilles inutiles
Windows("Cotations vérif_Final.xlsm").Activate
Range(Cells(1, 1), Cells(1, 8)).Select
Selection.Copy
Windows(nom & ".xlsx").Activate
Range("A1").Select
ActiveSheet.Paste
'copie des en-têtes
Windows("Cotations vérif_Final.xlsm").Activate
Range(Cells(t, 1), Cells(i, 8)).Select
Selection.Copy
Windows(nom & ".xlsx").Activate
Range("A2").Select
ActiveSheet.Paste
'copie des donnée entre les lignes t et i
ActiveWorkbook.Save
ActiveWorkbook.Close
Windows("Cotations vérif_Final.xlsm").Activate 'envoi du mail
Set ObjOutlook = New Outlook.Application
Set oBjMail = ObjOutlook.CreateItem(olMailItem)
With oBjMail
.To = Cells(t, 9) ' le destinataire
.Subject = Cells(t, 10) ' l'objet du mail
.Body = Cells(t, 11) 'le corps du mail ..son contenu
.Attachments.Add Chemin & "\" & nom & ".xlsx" '"C:\Data\essai.txt" ' ou Nomfichier
.Display
SendKeys "^{ENTER}" 'pour éviter la confirmation par outlook
End With
i = i + 1
a = a + 1
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'réactivation des alertes
End Sub |
MACRO envoyer par mail copie d'un tableau après filtre
Répondre avec citation
Envoyé par oriane13
Partager