Как скопировать слайды из существующей презентации в новую презентацию на основе конкретного ввода слайдов? - PullRequest
Новая
       36

Как скопировать слайды из существующей презентации в новую презентацию на основе конкретного ввода слайдов?

1 голос
/ 22 июня 2019

Это моя первая задача по макросам PPT.У меня есть код, который может копировать выбранные слайды и вставлять в новую презентацию, это занимает очень много времени, особенно при выборе не по порядку слайдов, например (1,2,5,8,9).Я ищу код, в котором мы можем дать конкретные номера слайдов в коде, как и выше (1,2,5,8,9), и я должен быть в состоянии изменить, когда мне нужно скопировать другой набор слайдов.Пожалуйста, посмотрите текущий код ниже и предложите соответственно. 

'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

1 Ответ

1 голос
/ 24 июня 2019

Это должно заменить ваш 'Сквозной слайд в SlideRange к концу. Вы должны быть в состоянии удалить все выбранные коды слайдов. Это просто просит пользователя ввести все номера слайдов, необходимые для копирования в списке через запятую. 

 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
...