Discussion :

[geutlastar]

Bonjour à tous,

Je cherche à copier coller puis positionner un ensemble de Shapes (Environs 250) depuis Excel vers PowerPoint. Pour information, le code se situe dans un module sous Excel.

J'arrive sans problème à copier coller l'ensemble des Shapes de Excel vers PowerPoint. Mais je n'arrive pas à déplacer la sélection dans le Powerpoint

Ci-dessous mon code :

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
Sub Copie()
 
 
'necessite d'activer la reference Microsoft Powerpoint Object Library
Dim PPT As PowerPoint.Application
Dim PptDoc As PowerPoint.Presentation
Dim NbShpe As Byte
 
Set Tdb = ThisWorkbook.Sheets("POC").Range("A1:I22")
Set PPT = CreateObject("Powerpoint.Application") 'creation session PowerPoint
PPT.Visible = True 'l'application sera visible
Set PptDoc = PPT.Presentations.Open("M:\Projet_Données_internationales\POC\POC.pptx") 'ouverture fichier ppt
 
 
ThisWorkbook.Sheets("POC").Shapes.SelectAll
Selection.Copy
PptDoc.Slides(2).Shapes.Paste
 
'With PptDoc.Slides(2).Shapes.SelectAll
'.Left = 38 'position horizontale dans le slide
'.Top = 120 'position verticale dans le slide
'End With
 
End Sub

En commentaire j'essaye de faire bouger la sélection mais cela ne fonctionne pas.

Merci pour votre aide

[E KERGRESSE]

Bonjour,

Il vous faut grouper vos formes une fois collées dans le slide, sinon elles vont se retrouver empilées au même endroit.

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
 
Sub Copie()
 
Dim PPT As PowerPoint.Application, PptDoc As PowerPoint.Presentation
Dim PptSlide As PowerPoint.Slide, PptShape As PowerPoint.Shape
Dim Tdb As Worksheet
 
 
    Set Tdb = Sheets("POC")
    Set PPT = CreateObject("Powerpoint.Application")
    PPT.Visible = True
 
    Set PptDoc = PPT.Presentations.Open("M:\Projet_Données_internationales\POC\POC.pptx")
    Set PptSlide = PptDoc.Slides(2)
 
    Tdb.Shapes.SelectAll
    Selection.Copy
 
    With PptSlide
         .Select
         .Shapes.Paste
         .Shapes.SelectAll
         Set PptShape = .Shapes.Range.Group
         With PptShape
              .Name = "POC"
              .Left = 38
              .Top = 120
         End With
    End With
 
    Set PptSlide = Nothing: Set PptDoc = Nothing:  Set PPT = Nothing: Set Tdb = Nothing
 
End Sub