如何根据特定的幻灯片输入将幻灯片从现有演示文稿复制到新演示文稿？

Question

This is my first task on PPT Macros. I have the code which can copy the selected slides and pastes into a new presentation, it is very time taking especially when selecting the slides which are not in order eg(1,2,5,8,9). I am looking for a code where we can give give specific slide numbers in the code, just like above (1,2,5,8,9) and I should be able to change when I have to copy different set of slides. Please look the current below code and suggest accordingly.

'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
y = 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

Answer 1

This should replace your 'Loop through slides in SlideRange to the end. You should be able to delete all the selected slide code. This just asks the user to input all the slide numbers needed to copy in a comma separated list.

 Sub testr()


 Dim SlideArray As Variant
'Set variable to Active Presentation
 Set OldPPT = ActivePresentation
'Create a brand new PowerPoint presentation
 Set NewPPT = Presentations.Add

    InSlides = InputBox("List the slide numbers separated by commas:", "Slides", 2)

    SlideArray = Split(InSlides, ",")

For x = 0 To UBound(SlideArray)
        sld = CInt(SlideArray(x))

'Set variable to a specific slide
Set Old_sld = OldPPT.Slides(sld)

'Copy Old Slide
y = 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