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
| Option Explicit
Sub PresentationPPT()
'
' PresentationPPT Macro
Dim PPTApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
' Open the PPT presentation
Set PPTApp = New PowerPoint.Application
PPTApp.Visible = True
PPTApp.Presentations.Open Filename:="Place of the ppt"
For Each PPTPres In PPTApp.Presentations
If PPTPres.Name = "ppt" Then
Dim WS As Worksheet
For Each WS In Worksheets
' Do not do it for sheet starting with the name X
If Left(WS.CodeName, 1) = "X" Then GoTo Skip
' Create a new slide to the presentation
Set PPTSlide = PPTPres.Slides.Add(PPTPres.Slides.Count + 1, ppLayoutText)
' Copy to the excel file
Windows("Excel file name").Activate
WS.Range("A1:AA149").Copy
Application.CutCopyMode = False
' Paste on last slide
PPTPres.SlideShowWindow.View.Last
PPTSlide.Shapes.PasteSpecial(ppPasteBitmap).Select
' Align the pasted range
PPTApp.ActiveWindow.Selection.ShapeRange.Align msoAlignLefts, True
PPTApp.ActiveWindow.Selection.ShapeRange.Align msoAlignBottoms, True
Skip:
Next
End If
Next
End Sub |
Partager