如何根据特定幻灯片输入将幻灯片从现有演示文稿复制到新演示文稿?
How to copy the slides from existing presentation to new presentation based on the specific slide input?
这是我在 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
这应该替换您的“在 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
这是我在 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
这应该替换您的“在 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