PDA

View Full Version : [SOLVED:] PLEASE HELP!!! Powerpoint Vba - Compiling slides from different sources files



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

John Wilson
03-26-2018, 03:53 AM
See if this gives you a start


Sub copymetoSection()
Dim oDonor As Presentation
Dim oTarget As Presentation
Dim osldR As SlideRange
Dim Sec As Long
Dim strName As String
strName = InputBox("Section Name?")
Set oDonor = ActivePresentation
Set oTarget = Presentations("Target") ' change name of course
oDonor.Slides.Range.Copy
oTarget.Windows(1).Activate
CommandBars.ExecuteMso ("PasteSourceFormatting")
DoEvents
Set osldR = ActiveWindow.Selection.SlideRange
Sec = getSecIndex(strName, oTarget)
osldR.MoveToSectionStart (Sec)
End Sub


Function getSecIndex(strName As String, opres As Presentation) As Long
For getSecIndex = 1 To opres.SectionProperties.Count
If opres.SectionProperties.Name(getSecIndex) = strName Then Exit Function
Next
End Function

iJerry
03-27-2018, 07:34 PM
Thank You John, your codes works like a charm.
I am still new to this but
How does the command "function" works?
When do we need to use it?