excel vba to copy powerpoint object between presentations

[LarryLewis]

Good Morning,

One of my bosses stared an excel file tat cud be used to copy slide objects from one presentation to another one. Currently something is not working right so i though i would come here to see if anyone has done this before. Currently i have one excel file that has the capability to "scrap chart", fancy name for creating a multiple slide power point file from an excel chart based on slicer input. What i am trying to do is copy those objects to specific slides in another presentation replacing the object that is already there. Example copy object 2 from source slide titled "name, yours" then paste it into Target slide titled "Y. NAME" object 4, this may change depending on how the target slides were originally built. What I am looking for is the code that will reference certain cells for file names, Source file name in cell "H1" and Target file Name in Cell "L1". Spreadsheet example below the row count can vary from one project to another based number personnel being used, anywhere from 1 to 30.

Column G Column H Column K Column
5 From slide name Shape #' To slide name Shape #'
6 Mouse, Mickey Picture 2 M. Mouse Object 5
7 Duck, Donald Picture 2 D. Duck Object 3
8
9

I have macros that will identify the correct shape/object on each slide that I want to replace. The issue seems to be in the current code that is supposed to do the copy & Paste actions. See Below

Under General Declarations He has the below

Dim fromPresentation As PowerPoint.Presentation
Dim toPresentation As PowerPoint.Presentation
Dim fromPowerPointApp As PowerPoint.Application
Dim toPowerPointApp As PowerPoint.Application
Dim PowerPointApp As PowerPoint.Application
Dim SeachPresentation As PowerPoint.Presentation
Dim intMultslide, intMultslide2 As Integer 'to count the slides with duplicate names

Sub PasteMultipleSlides()
    'PURPOSE: Copy PPT slides and Paste them into other PowerPoint presentation slides
    
    'declare some variables

    Dim fromMyShapesArray As Variant
    Dim toMyShapesArray As Variant
    Dim fromSlide As Slide
    Dim toSlide As Variant
    
    Dim x As Long
    Dim fromfile As String    Dim tofile As String
    Dim intRowcount As Integer
    
    Dim oshp As Shape
    
    'count the number of rows that have a "slides" listed in them
    Sheets("Tool").Select                                             [COLOR="#FF0000"]This is where it seems to hang up[/COLOR]
    Sheets("Tool").Range("G5").Select
    intRowcount = Range(Selection, Selection.End(xlDown)).Count + 4
    
    'Error handler for to many or zero files in list   [B][/B]
    If intRowcount > 31 Then
        intRowcount = 1
        Exit Sub
    End If
    
    'put the paths into a variables
    fromfile = Sheets("Tool").Cells(1, 8)
    tofile = Sheets("Tool").Cells(1, 12)
        
    'Create Application objects to reference the files
    Set fromPowerPointApp = GetObject(, "Powerpoint.Application") 'CreateObject("PowerPoint.Application")
    Set toPowerPointApp = GetObject(, "Powerpoint.Application") 'CreateObject("PowerPoint.Application")
    
    'Open powerpoint files
    Set fromPresentation = fromPowerPointApp.Presentations(fromfile)
    Set toPresentation = toPowerPointApp.Presentations(tofile)
        
    fromPowerPointApp.ActiveWindow.Panes(1).Activate 'Make PowerPoint Visible and Active
    
    For i = 6 To intRowcount 'do the following for every slide
        
        
        'turn the cell into a slide
        'first chesk to see if its duplicated
        If Sheets("Tool").Cells(i - 1, 7) <> Sheets("Tool").Cells(i, 7) Then
            intMultslide = 1
        Else
            intMultslide = intMultslide + 1
        End If
        
        Set fromSlide = FindSlideByTitle("From", Sheets("Tool").Cells(i, 7))
        fromSlide.Select
        
        'first chesk to see if its duplicated
        If Sheets("Tool").Cells(i - 1, 11) <> Sheets("Tool").Cells(i, 11) Then
            intMultslide2 = 1
        Else
            intMultslide2 = intMultslide2 + 1
        End If
        
        Set toMySlide = FindSlideByTitle("To", Sheets("Tool").Cells(i, 11))
        toMySlide.Select
        
        fromMyShapesArray = Split(Sheets("Tool").Cells(i, 8), ", ") 'List of PPT Shapes to copy from
        toMyShapesArray = Split(Sheets("Tool").Cells(i, 12), ", ") 'List of PPT Shapes to paste to
        
        'loop through from shapes and redefin the variable as the Shapes index
        ''For x = LBound(fromMyShapesArray) To UBound(fromMyShapesArray)
            'check for a carrage return and remove if it exists
            ''If InStr(1, fromMyShapesArray(x), Chr(10)) > 0 Then
                ''fromMyShapesArray(x) = Replace(fromMyShapesArray(x), Chr(10), "")
            ''End If
        ''Next x
        
        'loop through to shapes and redefin the variable as the Shapes index
        ''For x = LBound(toMyShapesArray) To UBound(toMyShapesArray)
            'check for a carrage return and remove if it exists
            ''If InStr(1, toMyShapesArray(x), Chr(10)) > 0 Then
                'toMyShapesArray(x) = Replace(toMyShapesArray(x), Chr(10), "")
            'End If
        'Next x
        
        'Loop through Array data, copy and paste slides
        For x = LBound(fromMyShapesArray) To UBound(fromMyShapesArray)
            
            fromSlide.Shapes(fromMyShapesArray(x)).Copy 'fromPresentation.Slides(fromSlide).Shapes(CInt(fromMyShapesArray(x))).Copy  'Copy shape
            
            intLeft = toMySlide.Shapes(toMyShapesArray(x)).Left
            intTop = toMySlide.Shapes(toMyShapesArray(x)).Top
            intHeight = toMySlide.Shapes(toMyShapesArray(x)).Height
            intWidth = toMySlide.Shapes(toMyShapesArray(x)).Width
            
            toMySlide.Shapes(toMyShapesArray(x)).Delete
            With toMySlide.Shapes.PasteSpecial 'iconLabel:=toMyShapesArray(x)  'Paste to PowerPoint and position
                .Height = intHeight
                .Width = intWidth
                .Left = intLeft
                .Top = intTop
                .Name = toMyShapesArray(x)
            End With
            'reposition
            'toMySlide.Shapes(toMyShapesArray(x)).Left = intLeft
            'toMySlide.Shapes(toMyShapesArray(x)).Top = intTop
          
        Next x
    Next i
    
    'Transfer Complete
    Application.CutCopyMode = False
    ThisWorkbook.Activate
    MsgBox "Complete!"

End Sub

If there are any suggestions for an easier and cleaner process that would be great.

 

[Rijnsent]

Hi LarryLewis,
some things that might help:
-Add a line: Set Wb = ActiveWorkbook , this is to keep the reference to your Excel file, even if you're working in other files.
- Set Sht = Wb.Sheets("Tool")
-Replace the Sheets("Tool") by Sht -> Sht.Range etc... -> again, this will help with the reference and make your code better readable.
-Get rid of the select statements:
intRowCount = Sht.Range(Sht.Range("G5"),Sht.Range("G5").End(xlDown)).Count +4
Hope that helps
Koen