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

FLEBY · 22 Mars 2020

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

Pounet95 · 22 Mars 2020

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

FLEBY · 22 Mars 2020

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

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

Staple1600 · 22 Mars 2020

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

Pounet95 · 22 Mars 2020

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ù !

Staple1600 · 22 Mars 2020

Re

Moi, je m'en sers peu, mais il est installé sur mon PC.
J'ai pu testé (et pendant le confinement ça change un peu d'Excel lol)
😉

FLEBY · 22 Mars 2020

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

FLEBY · 22 Mars 2020

UN GRAND MERCI ! SUPER !

Une dernière petite question : Peut-on générer un nouveau PowerPoint sans passer par un chemin d’accès ?

FLEBY · 22 Mars 2020

Pounet95 à dit:
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ù !

FLEBY · 22 Mars 2020

Je suis inscrit. Merci pour ta réponse 🙂

Pounet95 · 22 Mars 2020

Re,
Donc tu as pu charger le fichier ?
Pour un nouveau PPT , peut-être le créer en 1er puis en donner le chemin dans la macro.
Sinon voir dans l'aide PPT ( touche F1 )

FLEBY · 22 Mars 2020

Pounet95 à dit:
Re,
Donc tu as pu charger le fichier ?
Pour un nouveau PPT , peut-être le créer en 1er puis en donner le chemin dans la macro.
Sinon voir dans l'aide PPT ( touche F1 )

Je n'ai pas télécharger le fichier...

Je vais essayer cela. Je vous tiens informé.

Merci encore,

Bien cordialement,

Staple1600 · 22 Mars 2020

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.

FLEBY · 22 Mars 2020

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.

Je n'ai pas de mots pour exprimer ma gratitude. C'est super !!!!

FLEBY · 22 Mars 2020

Mon problème est résolu.

Comment fais t-on pour mettre un problème résolu ?

Effectuez une recherche sur Excel Downloads...

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

FLEBY

XLDnaute Nouveau

Pounet95

XLDnaute Occasionnel

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

FLEBY

XLDnaute Nouveau

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

Staple1600

XLDnaute Barbatruc

Pounet95

XLDnaute Occasionnel

Staple1600

XLDnaute Barbatruc

FLEBY

XLDnaute Nouveau

FLEBY

XLDnaute Nouveau

FLEBY

XLDnaute Nouveau

FLEBY

XLDnaute Nouveau

Pounet95

XLDnaute Occasionnel

FLEBY

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

FLEBY

XLDnaute Nouveau

FLEBY

XLDnaute Nouveau

Nous accordons de l'importance à votre vie privée