[VBA] copie graphique Excel vers Powerpoint (incorporer classeur

Question

Bonjour
je cherche à copier des graphiques Excel vers Powerpoint par macros
j'arrive à le copier mais les données restent liées à la feuille Excel
je voudrais que chaque graphique soit indépendant de la feuille Excel (données incorporées dans le fichier PPT)
j'arrive à faire la copie à la main en choisissant "collage spécial incorporer le fichier Excel", mais je n'arrive pas à trouver le code VBA pour le faire (même en enregistrant la macro manuellement)
Si quelqu'un connaît l'option pour le code VBA, ça me ferait gagner un temps fou
====
Sub NouvellePresentation()
Dim PptApp As PowerPoint.Application
Dim PptDoc As PowerPoint.Presentation
Dim Diapo As PowerPoint.Slide
Dim Sh As PowerPoint.Shape
Dim Cs1 As ColorScheme
Dim nbshpe As Integer
Dim Gr As Workbook

Set PptApp = CreateObject("Powerpoint.Application")
Set PptDoc = PptApp.Presentations.Add

With PptDoc

.Slides.Add Index:=1, Layout:=ppLayoutBlank

Set Sh = .Slides(1).Shapes.AddLabel(Orientation:=msoTextOrientationHorizontal, _
Left:=100, Top:=100, Width:=150, Height:=60)

Sh.TextFrame.TextRange.Text = Range("A1")

Sh.TextFrame.TextRange.Font.Color = RGB(255, 100, 255)

Set Diapo = .Slides.Add(Index:=2, Layout:=ppLayoutBlank)

'copie le 1er graphique contenu dans la feuille Excel active

ActiveSheet.ChartObjects(1).Copy
Diapo.Shapes.PasteSpecial
=================================================
=================================================
j'ai teste avec les options de PAsteSPecial et je ne trouve pas
================================================
================================================
nbshpe = Diapo.Shapes.Count

With Diapo.Shapes(nbshpe)
.Name = "monGraph" 'personnalise le nom
.Left = 150 'définit la position horizontale dans le slide
.Top = 100 'définit la position verticale dans le slide
.Height = 300 'hauteur
.Width = 400 'largeur
End With

PptDoc.SaveAs Filename:=ThisWorkbook.Path & "\" & "Eddie.pptx"
PptDoc.Close
PptApp.Quit

End Sub
======================
merci !
Eddie
      EDIT : Ajout des balises de code (la coloration syntaxique).
Explications disponibles ici : ICI 
Merci d'y penser dans tes prochains messages.

ucfoutu · Answer

Bonjour, 
Commence par corriger ce qui saute au yeux : deux blocs With et un seul End With.
remets ensuite ton code (corrigé) entre balises codes, s'il te plait.

Eddie69003 · Answer

voici le code corrigé :
Sub NouvellePresentation()Dim PptApp As PowerPoint.ApplicationDim PptDoc As PowerPoint.PresentationDim Diapo As PowerPoint.SlideDim Sh As PowerPoint.ShapeDim Cs1 As ColorSchemeDim nbshpe As IntegerDim Gr As WorkbookSet PptApp = CreateObject("Powerpoint.Application")Set PptDoc = PptApp.Presentations.AddWith PptDoc.Slides.Add Index:=1, Layout:=ppLayoutBlankSet Sh = .Slides(1).Shapes.AddLabel(Orientation:=msoTextOrientationHorizontal, _Left:=100, Top:=100, Width:=150, Height:=60)Sh.TextFrame.TextRange.Text = Range("A1")Sh.TextFrame.TextRange.Font.Color = RGB(255, 100, 255)Set Diapo = .Slides.Add(Index:=2, Layout:=ppLayoutBlank)'copie le 1er graphique contenu dans la feuille Excel activeDiapo.Shapes.PasteSpecial'======================================='j'ai teste avec les options de PAsteSPecial et je ne trouve pas'========================================nbshpe = Diapo.Shapes.Countend withWith Diapo.Shapes(nbshpe).Name = "monGraph" 'personnalise le nom.Left = 150 'définit la position horizontale dans le slide.Top = 100 'définit la position verticale dans le slide.Height = 300 'hauteur.Width = 400 'largeurEnd WithPptDoc.SaveAs Filename:=ThisWorkbook.Path & "\" & "Eddie.pptx"PptDoc.ClosePptApp.QuitEnd Sub
merci !
Eddie

cs_Le Pivert · Answer

Bonjour,
Comme ceci:
'Allez dans Outils-Références-Cochez Microsoft PowerPoint 11.0 Object Library
Option Explicit
Sub Inserer_graph()
Dim PptDoc As PowerPoint.Presentation
Dim Diapo As PowerPoint.Slide
Dim Sh As PowerPoint.Shape
Dim Cs1 As ColorScheme
Dim NbShpe As Integer

Dim PptApp As Variant
Set PptApp = CreateObject("Powerpoint.Application")
Set PptDoc = PptApp.Presentations.Add

With PptDoc
'--- Ajoute un nouveau slide
Set Diapo = .Slides.Add(Index:=1, Layout:=ppLayoutBlank)

'copie le 1er graphique contenu dans la feuille Excel active
ActiveSheet.ChartObjects(1).Copy
'collage dans la 1ère diapositive
Diapo.Shapes.Paste

'Compte le nombre de shapes dans la diapositive:
'le dernier objet inséré correspond à l'index le plus élevé
NbShpe = Diapo.Shapes.Count

'Renomme et met en forme l'objet collé
With Diapo.Shapes(NbShpe)
.Name = "monGraph" 'personnalise le nom
.Left = 150 'définit la position horizontale dans le slide
.Top = 100 'définit la position verticale dans le slide
.Height = 300 'hauteur
.Width = 400 'largeur
End With

End With

'Sauvegarde la présentation
'dans le meme répertoire que le classeur excel contenant la macro.
PptDoc.SaveAs FileName:=ThisWorkbook.Path & "\" & "NouvellePresentation_graph.ppt" 'enregistrer avec le classeur Excel, à modifier le chemin si besoin
'ferme la presentation
PptDoc.Close
'ferme powerpoint
PptApp.Quit

MsgBox "Opération terminée."

End Sub

Eddie69003 · Answer

Bonjour
Merci cS_Le Pivert mais ton code ne résout pas mon problème de collage des graphiques
En fait, mon client souhaiterais que les graphiques ne soient pas liées à un fichier Excel, mais incorporer dans PPT... comme un graphique créé directement dans PPT
J'arrive à le faire à la main en fait Copier "Utiliser le Thème de Destination et Incorporer le Classeur (S)"
Si j'enregistre la macro, je récupère ça :
    ActiveSheet.ChartObjects("Graphique 2").Activate     ActiveChart.ChartArea.Select    ActiveChart.ChartArea.Copy
Je n'ai même pas le ".Paste"
J'ai cherché dans les options de PasteSpecial et je ne retrouve pas cette option
Si tu connais ou si tu sais où je peux trouver cette option, merci par avance :)
Eddie

[VBA] copie graphique Excel vers Powerpoint (incorporer classeur

4 réponses

Votre réponse

Discussions similaires