[XL-2013] [VBA] Exporter des graphiques et des tableaux d'Excel vers Powerpoint en conservant la mise en forme source

[VBA] Exporter des graphiques et des tableaux d'Excel vers Powerpoint en conservant la mise en forme source

Bonjour à Tous,

Je suis un débutant dans l'embarras...J'ai parcouru plusieurs Forum, ça fait 24 heures que je bataille sur ce truc.
Pour mon stage je dois automatiser un tableau de bord avec des graphiques et des tableaux.

Premièrement j'ai une classe pour exporter les graphiques, puis une classe pour exporter les tableaux. Je n'arrive pas à fusionner les deux classes par manque
de savoir. j'aimerai créer un bouton qui exécute les 2 classes: Sub GraphExcel_vers_PowerPoint() et
Sub TableauexportPPT()

Deuxièmement, lorsque l'export se fait sur powerpoint. Je ne veux surtout pas que le graphique soit en tant qu'image. Parfois ça fonctionne, le copier coller se fait en gardant la mise en forme de type excel et parfois c'est une image.

Mon code n'est pas du tout optimiser mais j'essaye de faire de mon mieux :
MERCI à ceux qui veulent m'aider et pour votre pédagogie.

Code:

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
 
Sub GraphExcel_vers_PowerPoint()
                Dim sPPTFileName As String
                Dim ppApp As PowerPoint.Application
                Dim ppPres As PowerPoint.Presentation
                Dim cht As Excel.ChartObject
 
 
 
 
                    'Sélectionner le fichier PowerPoint à ouvrir
                       sPPTFileName = GetFileName
 
'Ouvrir PowerPoint
                   Set ppApp = CreateObject("PowerPoint.Application")
                   ppApp.Visible = msoTrue
                   Set ppPres = ppApp.Presentations.Open(sPPTFileName)
                   ppApp.ActiveWindow.ViewType = ppViewSlide
 
                        ' >>>>>>>>
                           'Appel de la fonction pour copier graphique dans PowerPoint
                           'Graphique no1
 
                        Set cht = ThisWorkbook.Sheets("SUIVI DES COMMANDES").ChartObjects("Graphique 1")
                        Call ChartsToPPT(ppPres, 2, cht, 130, 225, 465, 275)
 
                        'Set cht = ThisWorkbook.Sheets("SUIVI DES COMMANDES").
                        'Call ChartsToPPT(ppPres, 2, cht, 130, 405, 465, 150)
 
 
 
                        Set cht = ThisWorkbook.Sheets("SOCLE FIXE").ChartObjects("Graphique 1")
                        Call ChartsToPPT(ppPres, 2, cht, 335, 34, 170, 170) 'SOCLE PLACE
 
 
                        Set cht = ThisWorkbook.Sheets("SUIVI DES LIVRAISONS").ChartObjects("Graphique 1")
                        Call ChartsToPPT(ppPres, 3, cht, 130, 225, 465, 275)
 
                        Set cht = ThisWorkbook.Sheets("SUIVI DES LIVRAISONS").ChartObjects("Graphique 2")
                        Call ChartsToPPT(ppPres, 3, cht, 334, 36, 169, 159)
 
                        Set cht = ThisWorkbook.Sheets("SUIVI DES RECEPTIONS").ChartObjects("Graphique 1")
                        Call ChartsToPPT(ppPres, 4, cht, 130, 225, 465, 275)
 
                        Set cht = ThisWorkbook.Sheets("SUIVI DES VALIDATIONS").ChartObjects("Graphique 2")
                        Call ChartsToPPT(ppPres, 5, cht, 130, 225, 465, 275)
 
                        Set cht = ThisWorkbook.Sheets("SUIVI DES REFUS").ChartObjects("Graphique 1")
                        Call ChartsToPPT(ppPres, 6, cht, 130, 225, 465, 275)
 
                        Set cht = ThisWorkbook.Sheets("SUIVI DES RETARDS").ChartObjects("Graphique 1")
                        Call ChartsToPPT(ppPres, 7, cht, 130, 225, 465, 275)
 
 
 
 
 
 
 
                            Set cht = Nothing
                            Set ppPres = Nothing
                            Set ppApp = Nothing
 
End Sub
 
 
 'Code pour copier le graphique spécifié dans la présentation
Sub ChartsToPPT(oPPT As PowerPoint.Presentation, iSlideNo As Integer, _
                cht As ChartObject, iTop As Integer, iLeft As Integer, iWidth As Integer, iHeight As Integer)
 
                   Dim ppSlide As PowerPoint.Slide
                   Dim pSh As PowerPoint.Shape
   'Choisir la diapositive
                   Set ppSlide = oPPT.Slides(iSlideNo)
 
                   cht.Copy
 
                   With ppSlide
                      .Shapes.PasteSpecial 'ppPasteDefault
                      'Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
', SkipBlanks:=False, Transpose:=False
                      Set pSh = .Shapes(.Shapes.Count)  '.Select  'Select the last shape
                   End With
 
   'Position et dimensions
                   With pSh
                      .Top = iTop
                      .Left = iLeft
                      .Width = iWidth
                      .Height = iHeight
                   End With
 
End Sub
 
Function GetFileName() As String
   Dim sFileName As Variant
   Dim sFileFilter As String, sTitle As String
 
   'sFileFilter:="Excel Files (*.xls), *.xls", Title:="Please select a file"
   sFileFilter = "PowerPoint Files (*.ppt*), *.ppt*"
   sTitle = "Please select a file"
   sFileName = Application.GetOpenFilename(sFileFilter, , sTitle)
   If sFileName <> False Then
      GetFileName = sFileName
 
   End If
End Function
 
 
 
Sub TableauexportPPT()
   'nécessite d'activer la référence Microsoft Powerpoint Object Library
    Dim PPT As PowerPoint.Application
    Dim PptDoc As PowerPoint.Presentation
    Dim NbShpe As Byte
 
 
   sPPTFileName = GetFileName
    Set PPT = CreateObject("Powerpoint.Application")
    PPT.Visible = True 'l'application sera visible
    Set PptDoc = PPT.Presentations.Open(sPPTFileName)
 
 
    'premier tableau
 
        ThisWorkbook.Worksheets("SUIVI DES COMMANDES").Range("C33:O38").Copy
 
        PptDoc.Slides(2).Shapes.PasteSpecial ppPasteDefault 'ppPasteEnhancedMetafile
 
        NbShpe = PptDoc.Slides(2).Shapes.Count
 
        With PptDoc.Slides(2).Shapes(NbShpe)
            '.Name = "NomForme"
            .Left = 224
            .Top = 290
            .Height = 77
            .Width = 480
 
        End With
 
 
 
            ThisWorkbook.Worksheets("SUIVI DES LIVRAISONS").Range("C41:O46").Copy
 
        PptDoc.Slides(3).Shapes.PasteSpecial ppPasteDefault 'ppPasteEnhancedMetafile
 
        NbShpe = PptDoc.Slides(3).Shapes.Count
 
    '2 eme tableau
        With PptDoc.Slides(3).Shapes(NbShpe)
            '.Name = "NomForme"
            .Left = 224
            .Top = 290
            .Height = 77
            .Width = 480
 
        End With
 
 
                ThisWorkbook.Worksheets("SUIVI DES RECEPTIONS").Range("C41:O46").Copy
 
        PptDoc.Slides(4).Shapes.PasteSpecial ppPasteDefault 'ppPasteEnhancedMetafile
 
        NbShpe = PptDoc.Slides(4).Shapes.Count
 
        With PptDoc.Slides(4).Shapes(NbShpe)
            '.Name = "NomForme"
            .Left = 224
            .Top = 290
            .Height = 77
            .Width = 480
 
        End With
 
 
            ThisWorkbook.Worksheets("SUIVI DES VALIDATIONS").Range("C41:O46").Copy
 
        PptDoc.Slides(5).Shapes.PasteSpecial ppPasteDefault 'ppPasteEnhancedMetafile
 
        NbShpe = PptDoc.Slides(5).Shapes.Count
 
        With PptDoc.Slides(5).Shapes(NbShpe)
            '.Name = "NomForme"
            .Left = 224
            .Top = 290
            .Height = 77
            .Width = 480
 
        End With
 
 
           ThisWorkbook.Worksheets("SUIVI DES REFUS").Range("C41:O46").Copy
 
        PptDoc.Slides(6).Shapes.PasteSpecial ppPasteDefault 'ppPasteEnhancedMetafile
 
        NbShpe = PptDoc.Slides(6).Shapes.Count
 
        With PptDoc.Slides(6).Shapes(NbShpe)
            '.Name = "NomForme"
            .Left = 224
            .Top = 290
            .Height = 77
            .Width = 480
 
        End With
 
            ThisWorkbook.Worksheets("SUIVI DES RETARDS").Range("C41:O46").Copy
 
        PptDoc.Slides(7).Shapes.PasteSpecial ppPasteDefault 'ppPasteEnhancedMetafile
 
        NbShpe = PptDoc.Slides(7).Shapes.Count
 
        With PptDoc.Slides(7).Shapes(NbShpe)
            '.Name = "NomForme"
            .Left = 224
            .Top = 290
            .Height = 77
            .Width = 480
 
        End With
 
 
 
    'PptDoc.Save 'sauvegarder les modifications
    'PptDoc.Close 'fermer le document ppt
    'PPT.Quit 'fermer l'application powerPoint
 
End Sub

Cordialement

Rabik33

Bonjour,
J'ai tellement galéré sur ce sujet que maintenant je vais certainement pouvoir t'aider.

Pour cela, envoie en PJ, ton fichier Excel et également ton PPT, tel que tu voudrais qu'il apparaisse.
Met également le chemin complet où se trouve ton PPT afin qu'Excel puisse l'ouvrir.

1 pièce(s) jointe(s)

PJ

Ah merci beaucoup pour ton aide:
Voici la PJ du fichier: Pièce jointe 207061
La feuille "paramétrage" contient les 2 boutons pour l'export.
L'export se fait dans un fichier PPT quelque-conque il suffit qu'ils contiennent plus de 6 diapo.
Pas besoin de spécifier l'emplacement du PPT, j'ai créer une fonction pour ouvrir une boite de dialogue.

Ps je n'arrive pas à mettre en PJ le fichier PPT.

Cordialement

Rabik33

Citation:

Ps je n'arrive pas à mettre en PJ le fichier PPT.

Essaye en MP, peut etre que ça marchera.

:salut:

Citation:

Envoyé par RabiK33

Ps je n'arrive pas à mettre en PJ le fichier PPT.

Vous pouvez le zipper et essayer à nouveau de le joindre.

http://www.developpez.com/template/kit/kitwarning.png La taille maximale est de 2 Mo

Cordialement,
Malick

est ce que 7 diapo te convient ?
sinon il me faut ton PPT car je veux voir ou tu desires placer tes tableaux et tes graphes et surtout a quelles dimensions.
Je commence a bosser dessus demain et te rendrais ton fichier Dimanche ou au plus tard Lundi.
Dans l'attente de ton PPT

1 pièce(s) jointe(s)

Voici le Fichier powerpoint. Il est basique mais vous permettra de mieux comprendre
Pièce jointe 207072

Il suffit de lancer les macros et vous verrez le résultat.

Cordialement.

Rabik33

1 pièce(s) jointe(s)

Salut,
Ci joint le PPTM et XLS.
Modifie dans la macro le chemin d'accès au PPTM (PPT supportant les macros)
J'ai modifier ton XLS en créant une nlle feuille "SUIVI RESTE A LIVRER" car dans l'onglet "SUIVI DES COMMANDES", tu avais deux graphes portant le meme nom et ça créé un bug.
En esperant que cela te convienne.

N'oublies pas de cliquer sur :plusser: pour le travail réalisé et sur :resolu: pour clôturer ton post si nécessaire.

Merci à graphikris, je crois que je vais aussi profiter de son code.:P:P:P

Citation:

Envoyé par Philippe PONS

Merci à graphikris, je crois que je vais aussi profiter de son code.:P:P:P

N'oublies pas de cliquer sur :plusser: pour le travail réalisé

Merci Graphikris pour ton implication, ton code est super :)
-Par contre je voulais rajouter les tableaux qui sont en dessous des graphes. qui correspondent aux graphes. Mais je pense avoir trouvé la solution.
Merci encore.

Cordialement

Rabik33