IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Macros et VBA Excel Discussion :

Copier un tableau Excel vers PowerPoint [XL-2007]


Sujet :

Macros et VBA Excel

Vue hybride

Message précédent Message précédent   Message suivant Message suivant
  1. #1
    Membre confirmé
    Inscrit en
    Avril 2006
    Messages
    124
    Détails du profil
    Informations forums :
    Inscription : Avril 2006
    Messages : 124
    Par défaut Copier un tableau Excel vers PowerPoint
    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

    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

  2. #2
    Membre Expert
    Homme Profil pro
    Ingénieur développement matériel électronique
    Inscrit en
    Septembre 2013
    Messages
    783
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Isère (Rhône Alpes)

    Informations professionnelles :
    Activité : Ingénieur développement matériel électronique
    Secteur : High Tech - Électronique et micro-électronique

    Informations forums :
    Inscription : Septembre 2013
    Messages : 783
    Par défaut
    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

  3. #3
    Expert confirmé

    Homme Profil pro
    Curieux
    Inscrit en
    Juillet 2012
    Messages
    5 169
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Paris (Île de France)

    Informations professionnelles :
    Activité : Curieux
    Secteur : Arts - Culture

    Informations forums :
    Inscription : Juillet 2012
    Messages : 5 169
    Billets dans le blog
    5
    Par défaut
    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

  4. #4
    Membre confirmé
    Inscrit en
    Avril 2006
    Messages
    124
    Détails du profil
    Informations forums :
    Inscription : Avril 2006
    Messages : 124
    Par défaut 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 : 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????????????????

  5. #5
    Membre Expert
    Homme Profil pro
    Ingénieur développement matériel électronique
    Inscrit en
    Septembre 2013
    Messages
    783
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Isère (Rhône Alpes)

    Informations professionnelles :
    Activité : Ingénieur développement matériel électronique
    Secteur : High Tech - Électronique et micro-électronique

    Informations forums :
    Inscription : Septembre 2013
    Messages : 783
    Par défaut
    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

  6. #6
    Expert confirmé

    Homme Profil pro
    Curieux
    Inscrit en
    Juillet 2012
    Messages
    5 169
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Paris (Île de France)

    Informations professionnelles :
    Activité : Curieux
    Secteur : Arts - Culture

    Informations forums :
    Inscription : Juillet 2012
    Messages : 5 169
    Billets dans le blog
    5
    Par défaut
    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/

+ Répondre à la discussion
Cette discussion est résolue.

Discussions similaires

  1. [PPT-2003] Copier coller tableau Excel vers PP
    Par Kam's11 dans le forum VBA PowerPoint
    Réponses: 2
    Dernier message: 15/12/2017, 11h23
  2. [XL-2003] Copier un tableau excel vers word
    Par somig dans le forum Excel
    Réponses: 1
    Dernier message: 23/02/2013, 10h44
  3. Copier un tableau excel vers du word
    Par Colbix dans le forum Langage
    Réponses: 4
    Dernier message: 21/04/2010, 08h49
  4. Excel vers powerpoint : copier/coller spécial
    Par fabiencal dans le forum Macros et VBA Excel
    Réponses: 1
    Dernier message: 22/07/2009, 23h31
  5. [VBA-E]Excel vers powerpoint : copier/coller spécial
    Par illight dans le forum Macros et VBA Excel
    Réponses: 5
    Dernier message: 06/09/2006, 12h41

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo