Copier un tableau Excel vers PowerPoint

**jnauche** · 23/07/2015, 11h25

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

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

Et pour finir mon message d'erreur
Nom : Message d'erreur.jpg
Affichages : 1094
Taille : 15,5 Ko

Nom : Message d'erreur.jpg
Affichages : 1094
Taille : 15,5 Ko

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

**vinc_bilb** · 23/07/2015, 11h37

Bonjour,

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

**joe.levrai** · 23/07/2015, 12h18

Bonjour,

proposition naïve et non testée

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

**jnauche** · 23/07/2015, 15h00

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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????????????????

**vinc_bilb** · 23/07/2015, 17h05

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

Export_toPPT_ex.xlsm

**joe.levrai** · 23/07/2015, 18h39

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/

Copier un tableau Excel vers PowerPoint [XL-2007]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager