Transfer animation to another identical slide

OfficeTips Home || VBA Section || General Section || Download Section || Privacy Policy

Replicate animation from one slide to another identical slide

PowerPoint 2010 introduced two new methods for copying and transfering animations to another shape. We will use that to transfer animation from one slide to another identical slide. The follow assumptions are made. Both slides are identical, have shapes with the same names and the target slide has no previously assigned animations.

Supported versions: PowerPoint 2010+

' --------------------------------------------------------------------------------
' Copyright ©1999-2018, Shyam Pillai, All Rights Reserved.
' --------------------------------------------------------------------------------
' You are free to use this code within your own applications, add-ins,
' documents etc but you are expressly forbidden from selling or 
' otherwise distributing this source code without prior consent.
' This includes both posting free demo projects made from this
' code as well as reproducing the code in text or html format.
' --------------------------------------------------------------------------------

Sub Test()
Call TransferAnimation(ActivePresentation.Slides(1), ActivePresentation.Slides(2))
End Sub
 
Sub TransferAnimation(sourceSlide As Slide, targetSlide As Slide)
Dim sourceShape As Shape
Dim targetShape As Shape
Dim eft As Effect
Dim I As Integer
Dim col As New Collection
On Error Resume Next

' Multiple references not needed so use a collection to get only one reference of the shape with multiple animations

For I = 1 To sourceSlide.TimeLine.MainSequence.Count
    With sourceSlide.TimeLine.MainSequence(I)
        col.Add .Shape.Name, .Shape.Name
    End With
Next

'Apply the animation to the shapes on the french slide

For I = 1 To col.Count
   Set sourceShape = sourceSlide.Shapes(col(I))
   sourceShape.PickupAnimation
   Set targetShape = targetSlide.Shapes(col(I))
   targetShape.ApplyAnimation
Next

'Remap the animation to match source slide

For I = sourceSlide.TimeLine.MainSequence.Count To 1 Step -1
   With sourceSlide.TimeLine.MainSequence(I)
       Set eft = GetEffect(targetSlide, .Shape.Name, I)
       If Not eft Is Nothing Then
           eft.MoveTo I
       End If
   End With
Next
End Sub
 
Function GetEffect(sld As Slide, shapeName As String, startPosition As Integer) As Effect
Dim I As Integer
For I = startPosition To 1 Step -1
    With sld.TimeLine.MainSequence(I)
        If .Shape.Name = shapeName Then
            Set GetEffect = sld.TimeLine.MainSequence(I)
            Exit Function
        End If
    End With
Next
End Function