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
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
| Option Explicit
Sub PPTRecapProdCalibre()
'source : forum Developpez.com Auteur : Qwazerty 2 FEV-2011
'insertion du code Devis qui fonctionne avec sauts de pages et test adaptation
'==============================================================================
Dim objPPT As PowerPoint.Application
Dim objPres As PowerPoint.Presentation
Dim objSld As PowerPoint.Slide
Dim objSldMa As PowerPoint.Slide
Dim objShp As PowerPoint.Shape
Dim ObjShTable As PowerPoint.Shape
Dim ObjShMaTable As PowerPoint.Shape
Dim Tablo As Variant
Dim Tablo2 As Variant
Dim x As Integer, i As Integer, y As Integer
Dim NomTableau As String
Dim NLigne As Byte
Dim AskNewSlide As Boolean, SameTableau As Boolean
Const cstNbrMaxLigne As Byte = 10
Dim Derlig As Long
With Sheets("RecapGeneral")
'si aucune donnée dans la feuille, sortie de la procédure.
If IsEmpty(.UsedRange) Then Exit Sub
'Trouver la dernière ligne où il y a des données
'dans les colonnes A:C (à adapter)
Derlig = .Range("B:B").Find(what:="*", _
LookIn:=xlValues, _
searchorder:=xlByRows, _
searchdirection:=xlPrevious).Row
End With
'on utilise comme repère de fin de tableau une colonne où il y aura toujours des données sur chaque ligne
Tablo = Sheets("RecapGeneral").Range("B1:Z" & Derlig)
With Sheets("devis") 'pour récupérer le poids total de MA
Tablo2 = .Range("O1:Z2").Value
End With
'Ouvre POWEERPOINT
Set objPPT = CreateObject("Powerpoint.Application")
objPPT.Visible = True
'Ajoute une présentation
Set objPres = objPPT.Presentations.Add
objPres.SaveAs ThisWorkbook.Path & "\RecapProdCal.pptx"
'On charge le mod7le
objPres.ApplyTemplate ThisWorkbook.Path & "\PageModeleDevis.potx" 'modèle avec dessin en bas de page et logo SDF
'============================================================================================
'Pour le 1er tour on initialise AskNewSlide a true, on demande donc un nouveau Slide (le 1er)
AskNewSlide = True
For i = 1 To UBound(Tablo) 'On commence a 2 pour sauter les entetes de colonnes
'On regarde si une nouvelle feuille doit etre créée
'ici on regarde si le nom de tableau est vide
'S'il est vide => on a toujours le même tableau
If AskNewSlide Then
AskNewSlide = False
'On ajoute un nouveau Slide 'Layout avec un tableau de 10 lignes x 12 colonnes + un ligne d'entete au début (contenu dans le modèle potx)
Set objSld = objPres.Slides.AddSlide(objPres.Slides.Count + 1, objPres.SlideMaster.CustomLayouts(6))
'CustomLayouts(6) = dans PPT c'est le 6ème masque du modèle
'On renseigne le titre du slide
objSld.Shapes.Title.TextFrame.TextRange.Text = "Récapitulatif types de produits par calibre"
'on renseigne les propriétés du titre
objSld.Shapes.Title.TextFrame.TextRange.Characters.ChangeCase ppCaseSentence 'pour que le titre soit en minuscule
objSld.Shapes.Title.TextFrame.TextRange.Font.Size = 28 'et non en majuscule par défaut PPT titres
'si besoin changer la police
'objSld.Shapes.Title.TextFrame.TextRange.Font.Name = "brush script std" -->pour changer la police
'===============================================================================================
'On place le tableau dans l'espace reservé
Set ObjShTable = objSld.Shapes.AddTable(cstNbrMaxLigne, 12)
'On dimenssionne les colonnes
With ObjShTable.Table
.Columns(1).Width = 190 'famille produit
'les 10 cols ci-dessous reçoivent le nbre de projectiles par calibre
.Columns(2).Width = 60
.Columns(3).Width = 60
.Columns(4).Width = 60
.Columns(5).Width = 60
.Columns(6).Width = 60
.Columns(7).Width = 60
.Columns(8).Width = 60
.Columns(9).Width = 60
.Columns(10).Width = 60
.Columns(11).Width = 60
.Columns(12).Width = 60
'On formate le tableau avec un style vierge
.ApplyStyle "{2D5ABB26-0587-4C30-8999-92F81FD0307C}", True
End With
NLigne = 1 'On commencera donc directement a écrire sur la ligne 1
End If
'On Rajoute les données
'pour chaque cellule, on aligne le texte, on détermine la taille de police, on remplit avec les données :
With ObjShTable.Table
With ObjShTable
.Left = 35
.Top = 150
End With
With .Cell(NLigne, 1).Shape.TextFrame.TextRange 'reçoit le texte "famille du produit" ou "calibre"
.ParagraphFormat.Alignment = ppAlignLeft
.Font.Name = "Brush Script Std"
.Font.Size = 16
.Text = Tablo(i, 1)
End With
'les 11 cols ci-dessous recevront les calibres et les qtés de calibre (chiffres)
With .Cell(NLigne, 2).Shape.TextFrame.TextRange
.ParagraphFormat.Alignment = ppAlignRight
.Font.Name = "Brush Script Std"
.Text = Tablo(i, 2)
.Font.Size = 16
End With
With .Cell(NLigne, 3).Shape.TextFrame.TextRange
.ParagraphFormat.Alignment = ppAlignRight
.Font.Name = "Brush Script Std"
.Text = Tablo(i, 3)
.Font.Size = 16
End With
With .Cell(NLigne, 4).Shape.TextFrame.TextRange
.ParagraphFormat.Alignment = ppAlignRight
.Font.Name = "Brush Script Std"
.Text = Tablo(i, 4)
.Font.Size = 16
End With
With .Cell(NLigne, 5).Shape.TextFrame.TextRange
.ParagraphFormat.Alignment = ppAlignRight
.Font.Name = "Brush Script Std"
.Text = Tablo(i, 5)
.Font.Size = 16
End With
With .Cell(NLigne, 6).Shape.TextFrame.TextRange
.ParagraphFormat.Alignment = ppAlignRight
.Font.Name = "Brush Script Std"
.Text = Tablo(i, 6)
.Font.Size = 16
End With
With .Cell(NLigne, 7).Shape.TextFrame.TextRange
.ParagraphFormat.Alignment = ppAlignRight
.Font.Name = "Brush Script Std"
.Text = Tablo(i, 7)
.Font.Size = 16
End With
With .Cell(NLigne, 8).Shape.TextFrame.TextRange
.ParagraphFormat.Alignment = ppAlignRight
.Font.Name = "Brush Script Std"
.Text = Tablo(i, 8)
.Font.Size = 16
End With
With .Cell(NLigne, 9).Shape.TextFrame.TextRange
.ParagraphFormat.Alignment = ppAlignRight
.Font.Name = "Brush Script Std"
.Text = Tablo(i, 9)
.Font.Size = 16
End With
With .Cell(NLigne, 10).Shape.TextFrame.TextRange
.ParagraphFormat.Alignment = ppAlignRight
.Font.Name = "Brush Script Std"
.Text = Tablo(i, 10)
.Font.Size = 16
End With
With .Cell(NLigne, 11).Shape.TextFrame.TextRange
.ParagraphFormat.Alignment = ppAlignRight
.Font.Name = "Brush Script Std"
.Text = Tablo(i, 11)
.Font.Size = 16
End With
With .Cell(NLigne, 12).Shape.TextFrame.TextRange
.ParagraphFormat.Alignment = ppAlignRight
.Font.Name = "Brush Script Std"
.Text = Tablo(i, 12)
.Font.Size = 16
End With
End With
NLigne = NLigne + 1 'On passe a la ligne suivante de notre tableau sur le Slide
'====
'C'est ici que l'on regarde si une nouvelle diopa est necessaire
If NLigne > cstNbrMaxLigne Then AskNewSlide = True '+ 10 lignes
Next
'sous le premier tableau de données, on ajoute un petit tableau de 1 ligne et 4 cols
If AskNewSlide = False Then
Set objSldMa = objSld
Set ObjShMaTable = objSldMa.Shapes.AddTable(2, 4)
With ObjShMaTable.Table
.Columns(1).Width = 120 'famille produit
.Columns(2).Width = 100
.Columns(3).Width = 120 'famille produit
.Columns(4).Width = 100
'On formate le tableau avec un style vierge
.ApplyStyle "{2D5ABB26-0587-4C30-8999-92F81FD0307C}", True
With ObjShTable
.Left = 35
.Top = 800
End With
With .Cell(1, 1).Shape.TextFrame.TextRange
.ParagraphFormat.Alignment = ppAlignLeft
.Font.Name = "Brush Script Std"
.Font.Size = 16
.Text = "Poids Total Actif"
End With
With .Cell(1, 2).Shape.TextFrame.TextRange
.ParagraphFormat.Alignment = ppAlignRight
.Font.Name = "Brush Script Std"
.Text = Tablo2(2, 1)
.Font.Size = 16
End With
With .Cell(1, 3).Shape.TextFrame.TextRange
.ParagraphFormat.Alignment = ppAlignLeft
.Font.Name = "Brush Script Std"
.Font.Size = 16
.Text = "Poids Brut total"
End With
With .Cell(1, 4).Shape.TextFrame.TextRange
.ParagraphFormat.Alignment = ppAlignRight
.Font.Name = "Brush Script Std"
.Text = Format((Tablo2(2, 1) * 3.5), "# ##0") & " Kg"
.Font.Size = 16
End With
End With
End If
'Sauvegarde de "RecapProdCal.pptx"
objPres.save
'fermeture de POWERPOINT
objPres.Close
End Sub |
Rajouter un tableau sous un tableau PPT via Excel
Répondre avec citation
Partager