XL 2016 Copier tous les graphiques d'un classeur vers un PowerPoint

F

FLEBY

XLDnaute Nouveau
Bonjour,

Apres des heures de recherche , je n'ai pas trouvé la solution. Il y a des codes sur des forum, mais ils ne répondent pas à mon besoin.

En effet, je souhaiterais exporter tous les graphiques d'un classeur excel sur un PowerPoint. 1 graphique = 1 diapo

J'ai voulu adapter un code d'un livre mais ça dépasse mes connaissances (ci-joint)

Si quelqu'un peut m'orienter ... :)

Merci d'avance,

Cordialement
VB: 
Sub Excel_chart_to_PPT ()
 Dim PptApp As PowerPoint.Application
 Dim iSlide As PowerPoint.Slide
 Dim ChartObj As Excel.ChartObject
 On Error Resume Next
 Set PptApp = GetObject(, "PowerPoint.Application")
 On Error GoTo 0
 If PptApp Is Nothing Then
 Set PptApp = New PowerPoint.Application
 End If
 If PptApp.Presentations.Count = 0 Then
 PptApp.Presentations.Add
 End If
 PptApp.Visible = True
 For Each ChartObj In ActiveSheet.ChartObjects
 PptApp.ActivePresentation.Slides.Add
PptApp.ActivePresentation.Slides.Count + 1, ppLayoutText
 PptApp.ActiveWindow.View.GotoSlide
PptApp.ActivePresentation.Slides.Count
 Set iSlide =
PptApp.ActivePresentation.Slides(PptApp.ActivePresentation.Slides.Count
)
 ChartObj.Select
 ActiveChart.ChartArea.Copy ' j'ai une erreur à ce niveau également
 On Error Resume Next

iSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
 iSlide.Shapes(1).TextFrame.TextRange.Text =
ChartObj.Chart.ChartTitle.Text
 PptApp.ActiveWindow.Selection.ShapeRange.Left = 25
 PptApp.ActiveWindow.Selection.ShapeRange.Top = 150
 iSlide.Shapes(2).Width = 300
 iSlide.Shapes(2).Left = 600
 Next
 AppActivate ("Microsoft PowerPoint")
 Set iSlide = Nothing
 Set PptApp = Nothing
 
Trier par date Trier par votes
P

Pounet95

XLDnaute Occasionnel
Bonsoir,
Un petit tour sur le site Developpez.net
A condition d'être inscrit, il y a un fil dans lequel on peut récupérer un fichier TDB.rar ( à dézipper ) contenant de quoi répondre au problème posé ; un fichier excel .xlsm et un fichier ppt.pptm
Après il suffit d'adapter à ses besoins.
Je l'ai téléchargé mais je ne sais pas si j'ai le droit de le joindre ici ?
Si quelqu'un peut me dire ...
Merci
le lien :

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

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.
www.developpez.net
 
Vote positif 0 Vote négatif
F

FLEBY

XLDnaute Nouveau
Pounet95 à dit:
Bonsoir,
Un petit tour sur le site Developpez.net
A condition d'être inscrit, il y a un fil dans lequel on peut récupérer un fichier TDB.rar ( à dézipper ) contenant de quoi répondre au problème posé ; un fichier excel .xlsm et un fichier ppt.pptm
Après il suffit d'adapter à ses besoins.
Je l'ai téléchargé mais je ne sais pas si j'ai le droit de le joindre ici ?
Si quelqu'un peut me dire ...
Merci
le lien :

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

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.
www.developpez.net
Cliquez pour agrandir...
Un grand merci pour ta réponse.
J'ai parcouru la discussion et je ne trouve pas le fichier... Il y a un lien mais il me semble qu'il soit vide....
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Bonsoir le fil, FLEBY, Pounet95

Issu de mes archives anglophones (millésime 2019)
NB: test OK sur XL2013 (32bits + W10 64bits)
VB: 
Option Explicit
Public Sub ChartsToPpt()
Dim sht As Object, cht As Excel.ChartObject, appPpt As Object, prs As Object
Dim Fichier_PPT As String
Fichier_PPT = "C:\Users\STAPLE\Tests\XL2PPT.pptx" '-< adapter le chemin/nom du fichier
Set appPpt = CreateObject("PowerPoint.Application")
  appPpt.Visible = msoTrue
  Set prs = appPpt.Presentations.Open(Fichier_PPT)
  For Each sht In ActiveWorkbook.Sheets
    If sht.Visible = xlSheetVisible Then
      sht.Select
      Select Case LCase(TypeName(sht))
        Case "worksheet"
          For Each cht In sht.ChartObjects
            cht.Select
            Application.CommandBars.ExecuteMso "Copy"
            PasteChart appPpt, prs
          Next
        Case "chart"
          Application.CommandBars.ExecuteMso "Copy"
          PasteChart appPpt, prs
      End Select
    End If
  Next
End Sub

Private Sub PasteChart(ByVal PowerPointApplication As Object, ByVal TargetPresentation As Object)
Dim sld As Object, cnt As Long
Const ppLayoutBlank = 12
Const CtrlID1 = "PasteLinkedExcelChartDestinationTheme"
Const CtrlID2 = "PasteExcelChartSourceFormatting"
Set sld = TargetPresentation.Slides.Add(TargetPresentation.Slides.Count + 1, ppLayoutBlank)
  sld.Select
  cnt = sld.Shapes.Count
  With PowerPointApplication
    If .CommandBars.GetEnabledMso(CtrlID1) = True Then
      .CommandBars.ExecuteMso CtrlID1
    Else
      .CommandBars.ExecuteMso CtrlID2
    End If
  End With
  Do
   DoEvents
  Loop Until cnt <> sld.Shapes.Count
End Sub 'credit:kinuasa/20819(tech-c-m)[u]247409
 
Vote positif 0 Vote négatif
P

Pounet95

XLDnaute Occasionnel
Re,
J'ai précisé qu'il faut être inscrit sur le forum pour accéder aux chargements
sinon, effectivement il n'y a pas le lien pour charger le fichier
Staple 1600 : je ne me sert pas de PPT mais je vais mettre au chaud cette archive, au cas où !
 
Vote positif 0 Vote négatif
F

FLEBY

XLDnaute Nouveau
Staple1600 à dit:
Bonsoir le fil, FLEBY, Pounet95

Issu de mes archives anglophones (millésime 2019)
NB: test OK sur XL2013 (32bits + W10 64bits)
VB: 
Option Explicit
Public Sub ChartsToPpt()
Dim sht As Object, cht As Excel.ChartObject, appPpt As Object, prs As Object
Dim Fichier_PPT As String
Fichier_PPT = "C:\Users\STAPLE\Tests\XL2PPT.pptx" '-< adapter le chemin/nom du fichier
Set appPpt = CreateObject("PowerPoint.Application")
  appPpt.Visible = msoTrue
  Set prs = appPpt.Presentations.Open(Fichier_PPT)
  For Each sht In ActiveWorkbook.Sheets
    If sht.Visible = xlSheetVisible Then
      sht.Select
      Select Case LCase(TypeName(sht))
        Case "worksheet"
          For Each cht In sht.ChartObjects
            cht.Select
            Application.CommandBars.ExecuteMso "Copy"
            PasteChart appPpt, prs
          Next
        Case "chart"
          Application.CommandBars.ExecuteMso "Copy"
          PasteChart appPpt, prs
      End Select
    End If
  Next
End Sub

Private Sub PasteChart(ByVal PowerPointApplication As Object, ByVal TargetPresentation As Object)
Dim sld As Object, cnt As Long
Const ppLayoutBlank = 12
Const CtrlID1 = "PasteLinkedExcelChartDestinationTheme"
Const CtrlID2 = "PasteExcelChartSourceFormatting"
Set sld = TargetPresentation.Slides.Add(TargetPresentation.Slides.Count + 1, ppLayoutBlank)
  sld.Select
  cnt = sld.Shapes.Count
  With PowerPointApplication
    If .CommandBars.GetEnabledMso(CtrlID1) = True Then
      .CommandBars.ExecuteMso CtrlID1
    Else
      .CommandBars.ExecuteMso CtrlID2
    End If
  End With
  Do
   DoEvents
  Loop Until cnt <> sld.Shapes.Count
End Sub 'credit:kinuasa/20819(tech-c-m)[u]247409
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re

Pour créér un nouveau Powerpoint
Remplace (ou fais les modifs que j'ai faites) dans cette procédure ChartsToPpt
VB: 
Public Sub ChartsToPpt()
Dim sht As Object, cht As Excel.ChartObject, appPpt As Object, prs As Object
Dim Fichier_PPT As String
'''Fichier_PPT = "C:\Users\STAPLE\Tests\XL2PPT.pptx" '-< adapter le chemin/nom du fichier
Set appPpt = CreateObject("PowerPoint.Application")
  appPpt.Visible = msoTrue
  '''Set prs = appPpt.Presentations.Open(Fichier_PPT)
  Set prs = appPpt.Presentations.Add '<- pour créer un nouveau powerpoint
  For Each sht In ActiveWorkbook.Sheets
    If sht.Visible = xlSheetVisible Then
      sht.Select
      Select Case LCase(TypeName(sht))
        Case "worksheet"
          For Each cht In sht.ChartObjects
            cht.Select
            Application.CommandBars.ExecuteMso "Copy"
            PasteChart appPpt, prs
          Next
        Case "chart"
          Application.CommandBars.ExecuteMso "Copy"
          PasteChart appPpt, prs
      End Select
    End If
  Next
End Sub
NB: C'est celle de mon premier message, il faut évidemment garder l'autre procédure du premier message telle qu'elle.
 
Vote positif 0 Vote négatif
F

FLEBY

XLDnaute Nouveau
Staple1600 à dit:
Re

Pour créér un nouveau Powerpoint
Remplace (ou fais les modifs que j'ai faites) dans cette procédure ChartsToPpt
VB: 
Public Sub ChartsToPpt()
Dim sht As Object, cht As Excel.ChartObject, appPpt As Object, prs As Object
Dim Fichier_PPT As String
'''Fichier_PPT = "C:\Users\STAPLE\Tests\XL2PPT.pptx" '-< adapter le chemin/nom du fichier
Set appPpt = CreateObject("PowerPoint.Application")
  appPpt.Visible = msoTrue
  '''Set prs = appPpt.Presentations.Open(Fichier_PPT)
  Set prs = appPpt.Presentations.Add '<- pour créer un nouveau powerpoint
  For Each sht In ActiveWorkbook.Sheets
    If sht.Visible = xlSheetVisible Then
      sht.Select
      Select Case LCase(TypeName(sht))
        Case "worksheet"
          For Each cht In sht.ChartObjects
            cht.Select
            Application.CommandBars.ExecuteMso "Copy"
            PasteChart appPpt, prs
          Next
        Case "chart"
          Application.CommandBars.ExecuteMso "Copy"
          PasteChart appPpt, prs
      End Select
    End If
  Next
End Sub
NB: C'est celle de mon premier message, il faut évidemment garder l'autre procédure du premier message telle qu'elle.
Cliquez pour agrandir...


Je n'ai pas de mots pour exprimer ma gratitude. C'est super !!!!
 
Vote positif 0 Vote négatif

Discussions similaires

M
  • Résolu(e)
XL 2016 comment créer une Barre de défilement ou faire simplement défiler son texte ?
2
Réponses
25
Affichages
1 K
melltel
M
M
  • Question
XL 2013 MACRO VBA pour imprimer tous les bulletins d'un établissement scolaire
Réponses
4
Affichages
226
MBEPID
M
N
  • Résolu(e)
XL 2021 Exporter un graphique dans Outlook
Réponses
3
Affichages
441
NLSCt
N
I
  • Résolu(e)
Microsoft 365 Récupérer les données des variable dans une autre feuille du classeur
Réponses
3
Affichages
438
Icedarts
I
D
  • Résolu(e)
XL 2013 Copie vers un autre classeur avec condition
Réponses
2
Affichages
941
Dafaka7
D
K
  • Question
XL 2013 Worksheet_change copier/coller sur un autre classeur
Réponses
6
Affichages
805
Dafaka7
D
B
  • Question
XL 2016 Macro système d'archivage d'un tableau dans un autre tableau déroulant
Réponses
2
Affichages
506
babacool22
B
B
  • Question
Microsoft 365 Copier les données d'un tableau vers un autre
Réponses
12
Affichages
3 K
cp4
cp4
M
  • Question
Microsoft 365 faire une synthèse dans un classeur à partir d'un nombre aléatoire d'onglets
Réponses
5
Affichages
1 K
chris
chris
E
  • Question
XL 2010 Trier vers un onglet défini
Réponses
6
Affichages
1 K
elmilo13
E

Membres actuellement en ligne

9 membres et 118 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 109
Messages
2 116 320
Membres
112 717
dernier inscrit
doguet