iJerry
03-25-2018, 06:33 PM
Sometimes I have a huge PowerPoint deck filled with data slides from all sorts of departments.
My macro purpose is to open the source file, select all slides from it and paste it in specific section in the destination file. Then repeat for other departments.
e.g. Copied all slides from Source file from Sales department then paste into "Sales" section in destination file. Then repeat for copying all slides from Marketing department pasting into "Marketing" section in destination file.
I have done my researched but it rarely shows how to select specific section and paste it via vba.:(
Below are my code but I'd like to modified it as "Automatically copy all slides and paste into specific sections."
Thanks in advance :)
Sub Copy_Selection_To_New_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 AsLong, y AsLong
Dim myArray()AsLong
Dim SortTest AsBoolean
Dim i AsLong
Dim pp AsObject
Set pp = GetObject(,"PowerPoint.Application")
'Set variable to Active Presentation
Set OldPPT = pp.ActivePresentation
'Set variable equal to only selected slides in Active Presentation
Set Selected_slds = ActiveWindow.Select
'Sort Selected slides via SlideIndex
'Fill an array with SlideIndex numbers
ReDim myArray(1To 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
EndIf
Next y
LoopUntilNot SortTest
'Set variable equal to only selected slides in Active Presentation (in numerical order)
Set Selected_slds = OldPPT.Slides.Range(myArray)
'Active existing PowerPoint presentation
Set NewPPT = pp.Presentations("Testing.pptm")
'Loop through slides in SlideRange
For x =1To 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.MoveToSectionStart (1)
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
'End With
Next x
EndSub
My macro purpose is to open the source file, select all slides from it and paste it in specific section in the destination file. Then repeat for other departments.
e.g. Copied all slides from Source file from Sales department then paste into "Sales" section in destination file. Then repeat for copying all slides from Marketing department pasting into "Marketing" section in destination file.
I have done my researched but it rarely shows how to select specific section and paste it via vba.:(
Below are my code but I'd like to modified it as "Automatically copy all slides and paste into specific sections."
Thanks in advance :)
Sub Copy_Selection_To_New_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 AsLong, y AsLong
Dim myArray()AsLong
Dim SortTest AsBoolean
Dim i AsLong
Dim pp AsObject
Set pp = GetObject(,"PowerPoint.Application")
'Set variable to Active Presentation
Set OldPPT = pp.ActivePresentation
'Set variable equal to only selected slides in Active Presentation
Set Selected_slds = ActiveWindow.Select
'Sort Selected slides via SlideIndex
'Fill an array with SlideIndex numbers
ReDim myArray(1To 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
EndIf
Next y
LoopUntilNot SortTest
'Set variable equal to only selected slides in Active Presentation (in numerical order)
Set Selected_slds = OldPPT.Slides.Range(myArray)
'Active existing PowerPoint presentation
Set NewPPT = pp.Presentations("Testing.pptm")
'Loop through slides in SlideRange
For x =1To 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.MoveToSectionStart (1)
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
'End With
Next x
EndSub