Graphiques excel vers powerpoint en liaison

1 pièce(s) jointe(s)

Bonjour,

J'ai un fichier excel avec des feuilles graphiques. Je voudrais coller EN LIAISON chaque feuille graphique dans une nouvelle diapositive powerpoint, en gardant la même mise en forme graphique (même format, même couleurs, etc...).
Le collage en liaison permettra par la suite de mettre à jour via powerpoint directement sans relancer la macro.
Je débute dans VBA, j'ai seulement réussi à copier mon graphique et le coller sur une diapo, mais sans garder la mise en forme (les couleurs changent).

Pouvez-vous m'aider svp ?

Ci-joint mon fichier excel :

Bonsoir,

Très intéressant ton code, ça m'ouvre de nouvelles perspectives.
Je me suis permis d'ajouter quelques éléments :
Code:

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 Sub ppt() Dim ppt As PowerPoint.Application Dim pres As PowerPoint.Presentation Dim myslide As Slide Set ppt = CreateObject("PowerPoint.Application") ppt.Visible = True Set ppt = New PowerPoint.Application Set pres = ppt.Presentations.Open(Filename:="D:\Documents and Settings\Didier\Mes documents\VBA\Présentation.ppt") Charts("Graph1").Activate ActiveChart.ChartArea.Select ActiveChart.ChartArea.Copy N_shapes = ppt.Presentations(ppt.Presentations.Count).Slides(1).Shapes.Count ppt.Presentations(ppt.Presentations.Count).Slides(1).Shapes.PasteSpecial ppPasteMetafilePicture, link:=msoTrue With ppt.Presentations(ppt.Presentations.Count).Slides(1).Shapes(N_shapes + 1) .Left = 50 .Top = 50 .Width = 600 .Height = 400 End With End Sub
link:=msoTrue permet de lier ton image ppt à ton graphe Excel. Tu peux ensuite redimensionner, déplacer les images comme tu le souhaite. Je n'ai pas fait le tour des possibilités mais je pense qu'on peut aller loin.
J'ai ajouté aussi une variable N_shapes pour être sûr de redimensionner celle qu'on vient d'insérer.

Didier

J'ai réussi à faire ce que je voulais faire :

Code:

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
Sub ppt()
 
Call Initialisation
Call initialisation_couleurs
 
Dim ppt As PowerPoint.Application
Dim pres As PowerPoint.Presentation
Dim Diapo As PowerPoint.Slide
Dim NbShpe, cpt, cpt1, cpt2, cpt_row, cpt_col, fin_cpt As Integer
Dim modelePath, finalPath As Variant
Dim temp As String
Dim ws As Worksheet
Dim c As Chart
 
 
modelePath = Application.GetOpenFilename()
 
Set ppt = CreateObject("PowerPoint.Application") 'creation de l'objet powerpoint
ppt.Visible = True 'active powerpoint
Set ppt = New PowerPoint.Application
 
 
 
If modelePath <> False Then
 
    'ouverture du modèle de présentation
    Set pres = ppt.Presentations.Open(Filename:=modelePath)
 
 
    ws_croises.Previous.Select
    fin_cpt = Right(ActiveSheet.Name, 2)
 
 
'INITIALISATION DES COMPTEURS
'--------------------------------------------------------------------------------------------------------
    cpt = 1
    cpt1 = 2
    cpt2 = 4
'--------------------------------------------------------------------------------------------------------
 
    ws_taux.Select
 
    While cpt <> fin_cpt + 1
 
        Set Diapo = pres.Slides(cpt2)
        pres.Slides(pres.Slides.Count).Duplicate
 
 
'AFFICHAGE DES TITRES
'--------------------------------------------------------------------------------------------------------
        temp = Mid(ws_taux.Range("C" & cpt1), InStr(ws_taux.Range("C" & cpt1), " ") + 1, Len(ws_taux.Range("C" & cpt1)))
        Diapo.Shapes(1).TextFrame.TextRange.Text = temp
'--------------------------------------------------------------------------------------------------------
 
 
'AFFICHAGE DES TAUX DE REPONSES
'--------------------------------------------------------------------------------------------------------
        If ws_taux.Range("D" & cpt1).Value <> "NS" Then
            Diapo.Shapes(3).TextFrame.TextRange.Text = Left(ws_taux.Range("D" & cpt1).Value * 100, 4) & "%"
        Else
            Diapo.Shapes(3).TextFrame.TextRange.Text = ws_taux.Range("D" & cpt1).Value
        End If
'--------------------------------------------------------------------------------------------------------
 
 
'AFFICHAGE DES GRAPHIQUES
'--------------------------------------------------------------------------------------------------------
        For Each c In wb.Charts
            If Left(c.Name, 7) = "Graph" & cpt Then
 
                c.ChartArea.Copy
                Diapo.Shapes.PasteSpecial Link:=True
 
                ' 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 = 125 'définit la position horizontale dans le slide
                    .Top = 150 'définit la position verticale dans le slide
                    .Height = 350 'hauteur
                    .Width = 450 'largeur
                End With
            End If
        Next c
'--------------------------------------------------------------------------------------------------------
 
        'Application.Windows("Outil premiers résultats V20081020_bis.xls").Activate
 
 
'AFFICHAGE DES TABLEAUX (SI EXISTANTS)
'--------------------------------------------------------------------------------------------------------
        For Each ws In wb.Worksheets
 
            If Left(ws.Name, 5) = "Tab" & cpt Then
 
                cpt_row = 1
                cpt_col = 1
 
                While ws.Cells(cpt_row, 1) <> ""
                    cpt_row = cpt_row + 1
                Wend
 
                While ws.Cells(1, cpt_col) <> ""
                    cpt_col = cpt_col + 1
                Wend
 
                Set tabfin = ws.Range(ws.Cells(1, 1), ws.Cells(cpt_row - 1, cpt_col - 1))
                tabfin.Copy
                Diapo.Shapes.PasteSpecial Link:=True
 
                NbShpe = Diapo.Shapes.Count
 
                'renomme et met en forme l'objet collé
                With Diapo.Shapes(NbShpe)
                    '.Name = "monGraph" 'personnalise le nom
                    .Left = 125 'définit la position horizontale dans le slide
                    .Top = 450 'définit la position verticale dans le slide
                    .Height = 250 'hauteur
                    .Width = 350 'largeur
                End With
 
            End If
 
        Next ws
'--------------------------------------------------------------------------------------------------------
 
 
'INCREMENTATION DES COMPTEURS
'--------------------------------------------------------------------------------------------------------
        cpt = cpt + 1
        cpt1 = cpt1 + 1
        cpt2 = cpt2 + 1
'--------------------------------------------------------------------------------------------------------
 
 
 
    Wend
 
    'finalPath = Application.GetSaveAsFilename
 
    'If finalPath <> False Then
    '    pres.SaveAs (finalPath)
    'End If
 
End If
 
 
End Sub