Copier un tableau Excel vers PowerPoint

Version imprimable

1 pièce(s) jointe(s)

Bonjour,

Je cherche désespérément à coller des tableaux Excel dans une présentation PowerPoint.
L'ensemble des forums que j'ai pu consulté et les solutions qui ont été apportées ne me permettent pas de résoudre mon problème.

Je n'arrive pas à Coller : que ce soit en collage simple (PASTE) ou collage spécial (SPECIALPASTE).

J'ai simplifié au maximum mon code pour essayer de trouver l'origine mais rien n'y fait. Le voici
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 Chemin = Workbooks(ActiveWorkbook.Name).Path Fichier = Chemin & "\testcollage.pptx" Set Pwpt = CreateObject("PowerPoint.Application") Pwpt.Visible = True Set PresPpt = Pwpt.presentations.Open(Filename:=Fichier) Sheets("V2").Activate Sheets("V2").Cells(2, 2) = "Juillet" Range("C9").Select Selection.Copy PresPpt.Slides(1).Shapes.Paste
J'ai également essayé quelques collages spéciaux comme

Code:

PresPpt.Slides(1).Shapes.PasteSpecial (pppastebitmap)

Ici je remarque qu'en debuggeur pppastebitmap est vide bizaremment...

Et pour finir mon message d'erreur
Pièce jointe 183719

Je vous remercie par avance pour votre aide précieuse!!!
Je ne suis pas fermé à faire le copier depuis le powerpoint si cela peut être une issue (même si ca complexifie un peu la solution).

Cordialement,
Julien

Bonjour,

J'avais ça dans le passé qui fonctionnait bien .... à voir et à adapter si ça peut aider

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
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
Sub Init_settings_PPT()
'=============================================================================
' Init of the variables settings for the export to powerpoint
 
Subname = "Init_settings_PPT"
ThisWorkbook.Activate
 
If isdefined_range("PPT_EXPORT") = True Then
 
    InclRng = Range("PPT_EXPORT")(1, 3)
    Rng_name_type = Range("PPT_EXPORT")(1, 4)
    InclPivot = Range("PPT_EXPORT")(2, 3)
    InclGraph = Range("PPT_EXPORT")(3, 3)
    InserAsHLink = Range("PPT_EXPORT")(4, 3)
    CopyAsPict = Range("PPT_EXPORT")(5, 3)
 
Else: MsgBox "There is no valid range named PPT_EXPORT found in this project." & vbCrLf & _
        "Init of the parameters couldn't be done", vbExclamation, "ERROR: " & Subname
End If
 
End Sub
Sub export_to_powerpoint()
 
Dim nam As Name, shap As Shape, pivottab As PivotTable, graph As ChartObject
 
Subname = "export_to_powerpoint"
 
Dim PP_pres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim Cnt_item As Integer, Cnt_item_ptype As Integer  'Global counter and counter per type
Dim Log_copy As String
Dim Exc_Rng As Range
 
Dim PP_Tabl            As Table
Dim PP_TablRows As Integer, PP_TablCols As Integer
Dim PP_TablRow As Integer, PP_TablCol As Integer
Dim PP_MinTbl_dth    As Single
Dim PP_Shap As Variant
 
    ' Init
On Error GoTo Err_export_Ppt
ThisWorkbook.Activate
Call Init_settings_PPT                      'Load the options
 
    'Check whether the object libray is referenced and if PowerPoint is running
If Check_active_object_lib("PowerPoint") = False Then Exit Sub
Set PP_pres = get_Ppt_Pres
 
Application.ScreenUpdating = False
 
    ' Copy, if actif, the range named "PPT_Rng*"
If InclRng = True Then
 
    For Each nam In ThisWorkbook.Names
        If InStr(1, nam.Name, Rng_name_type, vbTextCompare) > 0 Then
 
            Set Exc_Rng = Range(nam.Name)
            Set PPSlide = AddNewPpt_Sl(PP_pres, True)
            Exc_Rng.Copy
 
            ' PastSpecial formats are ppPasteDefault, ppPasteHTML, ppPasteRTF, ppPasteText
 
                ' Copy as picture
            If CopyAsPict = True Then
                Exc_Rng.Copy
                PPSlide.Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=InserAsHLink
            End If
 
                ' Copy as table
            If CopyAsPict = False Then
 
                PPSlide.Shapes.AddTable Exc_Rng.Rows.Count, Exc_Rng.Columns.Count, 20, 120, 680
                Set PP_Tabl = PPSlide.Shapes(PPSlide.Shapes.Count).Table
 
                    'Pass the range to the table.
                For PP_TablRows = 1 To Exc_Rng.Rows.Count
                    For PP_TablCols = 1 To Exc_Rng.Columns.Count
                        PP_Tabl.Cell(PP_TablRows, PP_TablCols).Shape.TextFrame.TextRange.Text _
                            = Exc_Rng.Cells(PP_TablRows, PP_TablCols)
                            'Center alignment is used for cell contents.
                        PP_Tabl.Cell(PP_TablRows, PP_TablCols).Shape.TextFrame.TextRange.ParagraphFormat.Alignment _
                            = ppAlignCenter
                    Next PP_TablCols
                Next PP_TablRows
 
                    'Adjust the table width in order to save some slide space.
                With PP_Tabl
                    For PP_TablCol = 1 To .Columns.Count
                        PP_MinTbl_dth = 0
                        For PP_TablRow = 1 To .Rows.Count
                            With .Cell(PP_TablRow, PP_TablCol).Shape.TextFrame
                                If PP_MinTbl_dth = 0 Then PP_MinTbl_dth = .TextRange.BoundWidth + .MarginLeft + .MarginRight
                                If PP_MinTbl_dth < .TextRange.BoundWidth + .MarginLeft + .MarginRight + 1 Then _
                                   PP_MinTbl_dth = .TextRange.BoundWidth + .MarginLeft + .MarginRight
                            End With
                        Next
                        .Columns(PP_TablCol).Width = PP_MinTbl_dth
                    Next
                End With
            End If
 
                ' Add the tittle of the slide
            PPSlide.Shapes.Title.TextFrame.TextRange.Text = Exc_Rng.Worksheet.Name & " - " & nam.Name & " - link = " & InserAsHLink
 
                ' Log the items
            Cnt_item = Cnt_item + 1
            Cnt_item_ptype = Cnt_item_ptype + 1
            Log_copy = Log_copy & "Range " & vbTab & nam.Name & vbCrLf
        End If
    Next nam
End If
 
    ' Copy the graphs
If InclGraph = True And CInt(ActiveSheet.ChartObjects.Count) > 0 Then
    Cnt_item_ptype = 0
 
    For Each graph In ActiveSheet.ChartObjects
 
        Cnt_item = Cnt_item + 1
        Cnt_item_ptype = Cnt_item_ptype + 1
        Log_copy = Log_copy & "Graph " & vbTab & graph.Name & vbCrLf
 
        Set PPSlide = AddNewPpt_Sl(PP_pres)
        graph.Copy
 
        If CopyAsPict = True Then
            Set PP_Shap = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
        End If
        If CopyAsPict = False Then
            Set PP_Shap = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteDefault)
        End If
 
            ' Align the graph
        PP_Shap.Align msoAlignCenters, msoTrue
        PP_Shap.Align msoAlignMiddles, msoTrue
 
            ' Set the tittle
        PPSlide.Shapes.Title.TextFrame.TextRange.Text = ActiveSheet.Name & " - link = " & InserAsHLink
 
    Next graph
 
End If
 
    ' Copy the pivot table
If InclPivot = True And ActiveSheet.PivotTables.Count > 0 Then
    Cnt_item_ptype = 0
 
    For Each pivottab In ActiveSheet.PivotTables
 
        Cnt_item = Cnt_item + 1
        Cnt_item_ptype = Cnt_item_ptype + 1
        Log_copy = Log_copy & "Piv tbl " & vbTab & pivottab.Name & vbCrLf
 
        Set PPSlide = AddNewPpt_Sl(PP_pres)
 
            ' Assign a range as it seems difficult to manipulate the pivot table as it is
        Set Exc_Rng = pivottab.TableRange1
        Exc_Rng.Copy
 
        If CopyAsPict = True Then
            Set PP_Shap = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile, Link:=InserAsHLink)
        End If
 
        If CopyAsPict = False Then
 
            PPSlide.Shapes.AddTable Exc_Rng.Rows.Count, Exc_Rng.Columns.Count, 20, 120, 680
            Set PP_Tabl = PPSlide.Shapes(PPSlide.Shapes.Count).Table
 
                'Pass the range to the table.
            For PP_TablRows = 1 To Exc_Rng.Rows.Count
                For PP_TablCols = 1 To Exc_Rng.Columns.Count
                    PP_Tabl.Cell(PP_TablRows, PP_TablCols).Shape.TextFrame.TextRange.Text _
                        = Exc_Rng.Cells(PP_TablRows, PP_TablCols)
                        'Center alignment is used for cell contents.
                    PP_Tabl.Cell(PP_TablRows, PP_TablCols).Shape.TextFrame.TextRange.ParagraphFormat.Alignment _
                        = ppAlignCenter
                Next PP_TablCols
            Next PP_TablRows
 
                'Adjust the table width in order to save some slide space.
            With PP_Tabl
                For PP_TablCol = 1 To .Columns.Count
                    PP_MinTbl_dth = 0
                    For PP_TablRow = 1 To .Rows.Count
                        With .Cell(PP_TablRow, PP_TablCol).Shape.TextFrame
                            If PP_MinTbl_dth = 0 Then PP_MinTbl_dth = .TextRange.BoundWidth + .MarginLeft + .MarginRight
                            If PP_MinTbl_dth < .TextRange.BoundWidth + .MarginLeft + .MarginRight + 1 Then _
                               PP_MinTbl_dth = .TextRange.BoundWidth + .MarginLeft + .MarginRight
                        End With
                    Next
                    .Columns(PP_TablCol).Width = PP_MinTbl_dth
                Next
            End With
        End If
 
            ' Align the result
        PP_Shap.Align msoAlignCenters, msoTrue
        PP_Shap.Align msoAlignMiddles, msoTrue
 
               ' Add the tittle of the slide
        PPSlide.Shapes.Title.TextFrame.TextRange.Text = ActiveSheet.Name & " - link = " & InserAsHLink
 
    Next pivottab
 
End If
 
    ' End, notify an reset
ThisWorkbook.Activate
Application.ScreenUpdating = True
 
If Cnt_item > 0 Then
    Log_copy = "Following items have been copied to powerpoint" & vbCrLf & "with link to this file set to " & InserAsHLink & _
        vbCrLf & vbCrLf & Log_copy
    MsgBox Log_copy, , Subname
End If
 
Set PP_pres = Nothing
Set PPSlide = Nothing
 
 
Err_export_Ppt:
    If Err.Number <> 0 Then
        MsgBox Err.Number & vbCrLf & Err.Description, vbCritical, Subname
        Err.Clear
        Application.ScreenUpdating = True
        End
    End If
 
End Sub
 
Function AddNewPpt_Sl(PP_pres As PowerPoint.Presentation, Optional Prsrv_layout As Boolean = True) As PowerPoint.Slide
 
    Dim Ppt_Slide As Slide
 
        ' If presentation has no slide, add one with tittle only
    If PP_pres.Slides.Count = 0 Then
        Set Ppt_Slide = PP_pres.Slides.Add(1, ppLayoutTitleOnly)
 
    Else: Set Ppt_Slide = PP_pres.Slides.Add(PP_pres.Slides.Count + 1, ppLayoutTitleOnly)
    End If
 
    Set AddNewPpt_Sl = Ppt_Slide
End Function
 
Function get_Ppt_Pres() As PowerPoint.Presentation
'=============================================================================
' Run powerpaint application then select the destination presentation (new or active)
 
    Dim Ppt_App As PowerPoint.Application
    Dim Msganswer As String, Msgprompt As String
 
 
    Funcname = "get_Ppt_Pres"
 
        ' Activate powerpoint application or start it if not
    On Error Resume Next
    Set Ppt_App = GetObject(, "PowerPoint.Application")
 
 
        ' Launch powerpoint and make it visible
    If Ppt_App Is Nothing Then
        Set Ppt_App = CreateObject("PowerPoint.Application")
        Ppt_App.Visible = True
    End If
 
    On Error GoTo Err_Open_Ppt_
    Funcname = "get_Ppt_Pres"
 
        'Propose the active presentation, or create a new
    If Ppt_App.Windows.Count > 0 Then
        Msgprompt = "There is an active powerpaint presentation: " & Ppt_App.ActivePresentation.Name & vbCrLf & vbCrLf & _
            "=> Would you like to use it? (If No, a new presentation will be created)"
        Msganswer = MsgBox(Msgprompt, vbInformation + vbYesNo, Funcname)
        If Msganswer = vbYes Then
            Set get_Ppt_Pres = Ppt_App.ActivePresentation
            Else: Set get_Ppt_Pres = Ppt_App.Presentations.Add
        End If
    Else
        'There are no presentations - Create a New Presentation
        Set get_Ppt_Pres = Ppt_App.Presentations.Add
    End If
    Set Ppt_App = Nothing
 
Err_Open_Ppt_:
    If Err.Number <> 0 Then
        MsgBox Err.Number & vbCrLf & Err.Description, vbCritical, Funcname
        Err.Clear
        End
    End If
 
End Function

Bonjour,

proposition naïve et non testée

Code:

1
2
3
4
5
6
7
8
9
10
11
Chemin = Workbooks(ActiveWorkbook.Name).Path
Fichier = Chemin & "\testcollage.pptx"
 
Set Pwpt = CreateObject("PowerPoint.Application")
Pwpt.Visible = True
Set PresPpt = Pwpt.presentations.Open(Filename:=Fichier)
 
With Sheets("V2")
    .Cells(2, 2) = "Juillet"
    .Cells(9, 3).Copy PresPpt.Slides(1).Shapes
End With

Marche pas :(

Bonjour,

Tout d'abord merci vinc' et joe pour vos réponses.
Majheureusement ca ne marche pas.

Tout d'abord j'ai essayé joe :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 Chemin = Workbooks(ActiveWorkbook.Name).Path Fichier = Chemin & "\testcollage.pptx" Set Pwpt = CreateObject("PowerPoint.Application") Pwpt.Visible = True Set PresPpt = Pwpt.presentations.Open(Filename:=Fichier) 'Preparation du tableau V2 mois en cours pour le copier coller dans power point Sheets("V2").Activate With Sheets("V2") .Cells(2, 2) = "Juillet" .Cells(9, 3).Copy PresPpt.Slides(1).Shapes End With
Message d'erreur : "La méthode copy de la classe range a échoué"

Ensuite, je me suis penché sur le code de vinc' pour l'adapter ainsi
Code:

1 2 3 4 5 6 7 8 9 10 11 12 Chemin = Workbooks(ActiveWorkbook.Name).Path Fichier = Chemin & "\testcollage.pptx" Set Pwpt = CreateObject("PowerPoint.Application") Pwpt.Visible = True Set PresPpt = Pwpt.presentations.Open(Filename:=Fichier) Sheets("V2").Activate Sheets("V2").Cells(2, 2) = "Juillet" Range("C9").Select Selection.Copy PresPpt.Slides(1).Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=InserAsHLink
Message d'erreur : identique à ma première copie d'écran.
J'ai également essayé avec les autres collages spéciaux qui sont en commentaires dans ton code mais rien n'y fait...

Une autre idée svp????????????????

23/07/2015, 17h05
vinc_bilb

1 pièce(s) jointe(s)

Bonjour,

1. Avez-vous bien la référence à la librairie powerpoint acvtive?
2. Je vous joins un extract du support de cours que j'avais fait, testé, avec le code qui marche .... Je n'ai pas vraiment le temps de regarder dans le détail, j'ai juste vérifié que ça marchait encore. Désolé, c'est en anglais

Attention: les paramètres sont dans un range nommé "PPT_EXPORT"
PPT_EXPORT
Include data's range TRUE
Include pivot tables TRUE
Include graphs TRUE
Insert as hyperlink FALSE
Copy as picture TRUE

Pièce jointe 183750
23/07/2015, 18h39
joe.levrai

Je ne suis pas sûr que ce soit un problème de librairie, c'est de la liaison tardive là non ?
Tu peux nous montrer tes déclarations de variable, histoire qu'on soit sûr

Que cherches-tu à copier exactement ? Le contenu de la cellule ou l'objet "cellule" en lui-même ?

Regarde également par ici : http://www.developpez.net/forums/d23...er-powerpoint/

Bonjour,

À un certain moment, faisant face au même problème, j'avais fait une macro dans PowerPoint pour récupérer un tableau dans Excel et le refaire dans PowerPoint.

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
Sub TableauExcel()
    Dim AppExcel As Excel.Application
    Set AppExcel = New Excel.Application
    AppExcel.Visible = True
    Dim Classeur As Excel.Workbook
    Set Classeur = AppExcel.workbooks.Open("C:\Users\Clément Marcotte\Documents\ClasseurPowerPpoint.xlsm")
    Dim horizontal As Integer
    Dim vertical As Integer
    Dim Feuille As Excel.Worksheet
    Set Feuille = Classeur.Sheets("Feuil1")
    Dim plage As Range
    Set plage = Classeur.Sheets("Feuil1").UsedRange
    horizontal = plage.Columns.Count
    vertical = plage.Rows.Count
    'plage.Copy
    Dim Tableau As Table
    ActivePresentation.Slides(1).Shapes.AddTable NumRows:=vertical, Numcolumns:=horizontal, Width:=500, Height:=300
    Dim i As Integer
    Dim j As Integer
    Dim combien As Integer
    combien = ActivePresentation.Slides(1).Shapes.Count
    For i = 1 To vertical
        For j = 1 To horizontal
            ActivePresentation.Slides(1).Shapes(combien).Table _
            .Cell(i, j).Shape.TextFrame.TextRange _
            .Text = plage.Cells(i, j).Value
        Next
    Next
    Classeur.Close (True)
    AppExcel.Quit
End Sub

Merci pour vos réponses mais toujours pas

Bonjour,

Merci pour toutes ces réponses que j'ai regardé attentivement et j'ai fait quelques recherches complémentaires mais pour l'instant toujours rien

@Vinc'
Comment savoir si ma librairie est activée? J'ai cherché sur le net mais a chaque fois ce n'est pas pour Windows 2007... Je ne trouve pas cette ###### de coche!!

@Joe
J'ai suivi ton lien. J'ai extrait le bout de code qui me convient parfaitement. J'ai effectivement un probleme dans la déclaration de mes variables puisque je bloque directement sur la première ligne
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 Dim PptApp As PowerPoint.Application Dim PptDoc As PowerPoint.Presentation Set PptApp = CreateObject("Powerpoint.Application") PptApp.Visible = True Set PptDoc = PptApp.Presentations.Open("d:\Profiles\jNauche\Desktop\modele.pptx") With PptDoc 'copie la plage de cellules dans la feuille Excel active Sheets("V2").Range("B1:H5").Copy 'Effectue un collage dans la 2eme diapositive .Slides(2).Shapes.Paste End With
Erreur : "Type défini non défini par l'utilisateur

Et pour repondre à ta question, dans mes rêves les plus fou je veux copier un tableau, le coller au format image et le redimensionner. Mais comme ca marhce pas, j'essaie juste de réussir un copier coller d'une ou plusieurs cellules pour l'instant!

@Clement
Merci pour ce bout de code mais si je comprends bien, la tu récupères la dimension du tableau et tu remplies les cases une à une. Vu le nombre de tableau que j'ai a copier, les tailles de ceux ci et surtout le fait que je souhaite qu'in fine ce soit une image que j'ai dans le powerpoint, j'ai peur que cette solution ne soit pas tout a fait adaptée.

24/07/2015, 10h18
jnauche

Complément

Ca y est j'ai trouvé la librairie!! Ouf.
Elle était effectivement manquante.

Du coup j'ai relancé la macro conseillé par Joe. Je passe les déclarations. Mes espoirs sont immenses et patatra, exactement le meme message d'erreur...
Je suis dégoute, j'y ai tellement cru!

Et oui!!! C'est bon

J'ai réussi!!!! En utilisant le pastespecial et non le paste.

Donc la solution pour les suivants :

Lorsque vous avez ce message d'erreur :

1. Vérifier que la librairie a bien été ajoutée (solution Windows 2007. Pour se faire :
Dans la fenêtre des macro (et non dans excel "classique") : cliquer sur Outils / Références puis cocher Microsoft PowerPoint XXX Object Library

2. Ne pas utiliser le paste mais le pastespecial avec l'argument de votre choix en fonction du résultat souhaité
Soit par exmple ici
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 Dim PptApp As PowerPoint.Application Dim PptDoc As PowerPoint.Presentation Set PptApp = CreateObject("Powerpoint.Application") PptApp.Visible = True Set PptDoc = PptApp.Presentations.Open("d:\Profiles\jNauche\Desktop\modele.pptm") With PptDoc 'copie la plage de cellules dans la feuille Excel active Sheets("V2").Range("C9:E10").Copy 'Effectue un collage dans la 2eme diapositive .Slides(5).Shapes.PasteSpecial ppPasteMetafilePicture 'With .Slides(2).Shapes(.Slides(2).Shapes.Count) ' .Name = "monTableau" 'Renomme l'objet collé ' .Left = 150 'position horizontale dans le slide ' .Top = 100 'position verticale dans le slide ' .Height = 300 'hauteur ' .Width = 400 'largeur 'End With 'insère le contenu de la cellule A1 dans la deuxième zone de texte, 'du 3eme slide '.Slides(3).Shapes(2).TextFrame.TextRange.Text = Range("A1") 'sauvegarde la présentation '.Save End With
Merci a tous pour votre aide.

24/07/2015, 16h01
vinc_bilb

Citation:

""Type défini non défini par l'utilisateur"

=> c'est typiquement la signature d'une bourde facile ou plus généralement d'une référence 'Object library' manquante .....

Le code que je vous avais fourni vous permet aussi de copier des graphes, des tables pivot, avec/sans hyperlien ....
Bonne continuration