VBA for MS Power Point

Maria010

New Member
Joined
Jan 11, 2017
Messages
3
I have this VBA code that works in MS PowerPoint. When I select a bunch of slides; the macro copies them into a new PowerPoint presentation. It works well if the presentation contains 20 slides. However, I have 200 slides and need to work with the number of each particular slide. How to select a bunch of slides based on the number (of slides) and copy them into a new presentation?

Sub Test_PPT()
Dim NewPPT As Presentation

Dim OldPPT As Presentation
Dim Selected_slds As SlideRange
Dim Old_sld As Slide
Dim New_sld As Slide
Dim x As Long, y As Long
Dim myArray() As Long
Dim SortTest As Boolean

'Set variable to Active Presentation
Set OldPPT = ActivePresentation

'Set variable equal to only selected slides in Active Presentation
Set Selected_slds = ActiveWindow.Selection.SlideRange

'Sort Selected slides via SlideIndex
'Fill an array with SlideIndex numbers
ReDim myArray(1 To Selected_slds.Count)
For y = LBound(myArray) To UBound(myArray)
myArray(y) = Selected_slds(y).SlideIndex
Next y

'Sort SlideIndex array
Do
SortTest = False
For y = LBound(myArray) To UBound(myArray) - 1
If myArray(y) > myArray(y + 1) Then
Swap = myArray(y)
myArray(y) = myArray(y + 1)
myArray(y + 1) = Swap
SortTest = True
End If
Next y
Loop Until Not SortTest

'Set variable equal to only selected slides in Active Presentation (in numerical order)
Set Selected_slds = OldPPT.Slides.Range(myArray)

'Create a brand new PowerPoint presentation
Set NewPPT = Presentations.Add

'Align Page Setup
NewPPT.PageSetup.SlideHeight = OldPPT.PageSetup.SlideHeight
NewPPT.PageSetup.SlideOrientation = OldPPT.PageSetup.SlideOrientation
NewPPT.PageSetup.SlideSize = OldPPT.PageSetup.SlideSize
NewPPT.PageSetup.SlideWidth = OldPPT.PageSetup.SlideWidth

'Loop through slides in SlideRange
For x = 1 To Selected_slds.Count

'Set variable to a specific slide
Set Old_sld = Selected_slds(x)

'Copy Old Slide
yy = Old_sld.SlideIndex
Old_sld.Copy

'Paste Slide in new PowerPoint
NewPPT.Slides.Paste
Set New_sld = Application.ActiveWindow.View.Slide

'Bring over slides design
New_sld.Design = Old_sld.Design

'Bring over slides custom color formatting
New_sld.ColorScheme = Old_sld.ColorScheme

'Bring over whether or not slide follows Master Slide Layout (True/False)
New_sld.FollowMasterBackground = Old_sld.FollowMasterBackground

Next x


End Sub​
 

Some videos you may like

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.

Watch MrExcel Video

Forum statistics

Threads
1,123,320
Messages
5,600,935
Members
414,417
Latest member
Nobu

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top