Saturday, 14 November 2015

Excel VBA Macro to Copy Specific Slides from One Presentation to Multiple Presentations

How to Copy Specific Slides from One PowerPoint Presentation to other Multiple Presentations with VBA Macro :
The following Macro example copies the specific Slides from source Presentation and Pasting at the specified Slide Index in the Target Presentations...

Sub Copy_Slides_from_One_to_Multiple_Presentations()
    Dim New_PowerPoint As Object
    Dim Src_PPT As PowerPoint.Presentation
    Dim Tgt_PPT As PowerPoint.Presentation
    
    Alert = MsgBox("The Macro will Merge Slides from Source Presentation to Multiple Target                     Presentations ", vbOKCancel, "Please Confirm to Go / Cancel")

    If Alert = vbCancel Then Exit Sub

    Set Run_Tab = ThisWorkbook.Sheets("Run_Process")
    Set CPanel_Tab = ThisWorkbook.Sheets("CPanel")
   
    Src_PPT_Path = CPanel_Tab.Range("D22").Value
    Tgt_PPT_Path = CPanel_Tab.Range("D25").Value
    Src_PPT_Name = "My_Source_Presentation_*.ppt*"
       
    Set New_PowerPoint = Nothing
    On Error Resume Next
    Set New_PowerPoint = GetObject(, "PowerPoint.Application")
    On Error GoTo 0
    
 '<< Check whether a PPT Application is Open if open Close and open a New Application >>
        If New_PowerPoint Is Nothing Then
                     Set New_PowerPoint = New PowerPoint.Application
                     New_PowerPoint.Visible = msoCTrue
                     New_PowerPoint.DisplayAlerts = False
           Else
                     New_PowerPoint.Quit
                     Set New_PowerPoint = New PowerPoint.Application
                     New_PowerPoint.Visible = msoCTrue
                     New_PowerPoint.DisplayAlerts = False
           On Error GoTo 0
        End If
        
   
    Src_PPT_File = Dir(Src_PPT_Path & "\" & Src_PPT_Name)
      
    Set Src_PPT = New_PowerPoint.Presentations.Open(Src_PPT_Path & "\" &                                                          Src_PPT_File)
    
        For X = 1 To 2
    
            If X = 1 Then
                    Tgt_PPT_Name = "Target-East_*.ppt*"
                    Tgt_PPT_File = Dir(Tgt_PPT_Path & "\" & Tgt_PPT_Name)
                    
                    Set Tgt_PPT = New_PowerPoint.Presentations.Open(Tgt_PPT_Path & "\" &                                                          Tgt_PPT_File)
                
                 'Activating the Source Presentation and Copying the Specific Slides
                    Src_PPT.Windows(1).Activate
                    Src_PPT.Slides.Range(Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13)).Copy
                 
                 'Activating the Target Presentation and Pasting at/after Target Slide(Index) 
                    Tgt_PPT.Windows(1).Activate                                
                    Tgt_PPT.Slides.Paste Index:=10
                    Tgt_PPT.Save
                    Tgt_PPT.Close
                    
                ElseIf X = 2 Then
                    Tgt_PPT_Name = "Target-West_*.ppt*"
                    Tgt_PPT_File = Dir(Tgt_PPT_Path & "\" & Tgt_PPT_Name)
                    
                    Set Tgt_PPT = New_PowerPoint.Presentations.Open(Tgt_PPT_Path & "\" &                                                          Tgt_PPT_File)
                    
                'Activating the Source Presentation and Copying the Specific Slides
                    Src_PPT.Windows(1).Activate
                    Src_PPT.Slides.Range(Array(15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25)).Copy
                    
                 'Activating the Target Presentation and Pasting at/after Target Slide(Index)
                    Tgt_PPT.Windows(1).Activate
                    Tgt_PPT.Slides.Paste Index:=15                    
                    Tgt_PPT.Save
                    Tgt_PPT.Close
                  
            End If
            
        Next X
        
    Src_PPT.Close
    New_PowerPoint.Quit
    Set New_PowerPoint = Nothing
    Set Src_PPT = Nothing
    Set Tgt_PPT = Nothing
    
 MsgBox "Specific Slides from Source to Target Presentations Copied Successfully",  vbOKOnly, "Final Presentation Ready"
End Sub

Thanks,
TAMATAM

No comments:

Post a Comment

Follow Me by Email

ExcelKingdom-Popular Posts

ExcelKingdom-Random Posts