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
| Sub Liste()
For Each cel In Range("SuppSelect")
If cel.Value = "" Or cel.Value = 0 Then Exit Sub
Sheets("Review").Range("E4") = cel.Value
Call Feuil8.test
Next cel
End Sub
Sub test()
'nécessite d'activer la référence Microsoft Powerpoint Object Library
Dim PPT As Object
Dim PptDoc As Object
Dim NbShpe As Byte
Dim PPSlide As PowerPoint.Slide
Dim Slidecount As Integer
Set PPT = CreateObject("Powerpoint.Application")
PPT.Visible = True 'l'application sera visible
Set PptDoc = PPT.Presentations.Open("U:mapresentation.pptx")
ActiveSheet.Range("E4:Z13").Copy
Slidecount = PptDoc.Slides.Count
PptDoc.Slides(Slidecount).Shapes.Paste
NbShpe = PptDoc.Slides(Slidecount).Shapes.Count
With PptDoc.Slides(Slidecount).Shapes(NbShpe)
.Left = 17
.Top = 120
.Height = 250
.Width = 687
End With
Slidecount = PptDoc.Slides.Count
Set PPSlide = PptDoc.Slides.Add(Slidecount + 1, ppLayoutTitleOnly)
PptDoc.Save 'sauvegarder les modifications
PptDoc.Close 'fermer le document ppt
PPT.Quit 'fermer l'application powerPoint
End Sub |
Partager