Looking for some assistance in tweaking this code (that another forum user graciously helped me with)

ajjava

Board Regular
Joined
Dec 11, 2018
Messages
57
Office Version
  1. 365
Platform
  1. Windows
In a nutshell, the code below takes several picture objects from an Excel workbook (they are charts, but the source system puts them into Excel as pics) and pastes them into a PowerPoint presentation. As it stands, the code works. I just need some modifications to make a bit more dynamic.
For instance:
* Would like to NOT have a hard-coded value for starting number of slides (note in the 'assumptions' section, it is currently defined as 23. In the actual code, I may have modified the values that correspond to this, in case it seems like it doesn't line up)
* As it stands, the code is written to just loop through ALL of the worksheets, grabbing any pics that might be there. Would like to add code to reference ONLY specific worksheets, based on permanent and predefined names (so for example, the first sheet is named "New Total", the next is "New Where", etc.) If I could just see the correct syntax for one sheet, I can then code the rest, based on that.
* And here is what is likely the biggest change: There are three different Excel workbooks that need to be combined into one PowerPoint deck. So, in English, the flow would go like this:
  1. Open the first workbook
  2. Select the first specific worksheet
  3. Copy/paste each picture object into a new, blank ppt deck
    • 2 pics per slide, plus a rectangle shape box
  4. Go back to Excel
  5. Select the next specific worksheet....repeat steps 2-3 until all defined worksheets have been addressed
  6. Close that workbook
  7. Open the next workbook....repeat above steps 2-6
  8. Finished result is a many-slides PowerPoint, with ALL the picture objects from ALL the worksheets in all 3 workbooks
    • Each slide has 2 pics, plus a rectangle shape box

Here is the existing code:
Code:
Sub CreateExecSummary2()
'Assumptions

'There will always be ONLY 4 images on each worksheet in the ERP workbook.
'The "base" PPT pres will ALWAYS start with 23 slides, each with only a Title Box (look into changing code to make this dynamic)
'That each of the image slides will ONLY have three shapes. Two images and 1 title box
'The first image on the slide will ALWAYS BE THE TOP ONE.
'The second image on the slide will ALWAYS BE THE BOTTOM ONE.
        
    'Declare PowerPoint Variables
    Dim PPTApp As PowerPoint.Application
    Dim PPTPres As PowerPoint.Presentation
    Dim PPTSlide As PowerPoint.Slide
    Dim PPTShape As PowerPoint.Shape
    Dim SldArray(44) As Variant
    Dim i As Integer
    
    'Declare Excel Variables.
    Dim filePath As String
    Dim WrkSht As Worksheet
    Dim PicCntr, SldCntr, ShpCount, StartingSld As Integer
    Dim Shp As Shape

    'Open a file dialog to go and fetch the file path, if invalid file path is presented it will exit sub.
    filePath = Excel.Application.GetOpenFilename("Executive Summary (*.pptm*),*.pptm*", _
                                                 1, "Executive Summary Template to Populate", , False)
    If filePath = "" Then GoTo noFile
    
    'Check if the PowerPoint App is open, if not create a new instance of PowerPoint and finally make the PowerPoint Visible.
    On Error Resume Next
       Set PPTApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0

    If PPTApp Is Nothing Then
       Set PPTApp = New PowerPoint.Application
    End If
    
    'Make PowerPoint Visible
    PPTApp.Visible = True

    'Set the Presentation to the file select.
    Set PPTPres = PPTApp.Presentations.Open(filePath)
    
    'Build a slide array so that way we can easily paste the pictures on the right slide.
    StartingSld = 2

    For i = 0 To 42 Step 2
        SldArray(i) = StartingSld
        SldArray(i + 1) = StartingSld
        StartingSld = StartingSld + 1
    Next
    
    PicCntr = 0
    
    'Loop through each of the worksheets in the ERP Generated Workbook
    For Each WrkSht In ActiveWorkbook.Worksheets
    
        'Activate the Worksheet, for stability issues that may arise.
        WrkSht.Activate
        
        'Loop through each shape on the Worksheet.
        For Each Shp In WrkSht.Shapes
        
            'If the shape is a picture, then continue.
            If Shp.Type = msoPicture Then
               
               'Set a reference to the slide, we select the right slide by leveraging the PicCntr.
               Set PPTSlide = PPTPres.Slides(SldArray(PicCntr))
                
                   'Copy the shape, and pause for stability issues thay may arise.
                   Shp.Copy
                   Application.Wait Now() + #12:00:01 AM#
                   
                   'Paste the shape and increase the PicCntr by 1, so that we proceed to the next element in our SldArray on the next pic.
                   PPTSlide.Shapes.Paste
                   PicCntr = PicCntr + 1
                 
               'Get the total shape count, and set a reference to the shape we want to work with.
               ShpCount = PPTSlide.Shapes.Count
               Set PPTShape = PPTSlide.Shapes(ShpCount)
               
               'Assume the First Shape is the Top one, the reason I put ShpCount 2 is because we have to include the title box.
               If ShpCount = 2 Then
                                 
                    'Set the dimensions of the shape.
                    With PPTShape
                        .Top = Excel.Application.InchesToPoints(1.04)
                        .Left = Excel.Application.InchesToPoints(3.09)
                        .Height = Excel.Application.InchesToPoints(3.07)
                        .Width = Excel.Application.InchesToPoints(6.42)
                 
                    End With
                                   
               'Assume the Second Shape is the bottom one, the reason I put ShpCount 3 is because we have to include the title box.
               ElseIf ShpCount = 3 Then
               
                    'Set the dimensions of the shape.
                    With PPTShape
                         .Top = Excel.Application.InchesToPoints(4.33) 'CHANGE THIS SO IT MATCHES WHAT YOU HAVE FOR THE BOTTOM IMAGE.
                        .Left = Excel.Application.InchesToPoints(3.09)
                        .Height = Excel.Application.InchesToPoints(2.81)
                        .Width = Excel.Application.InchesToPoints(6.42)
                    End With
               
               'Add the text box.
               PPTSlide.Shapes.AddShape(Type:=msoShapeRoundedRectangle, Left:=27.36, Top:=84.96, Width:=159.12, Height:=400.32).TextFrame.TextRange.Text = "Please Enter Analysis Here."
               
               End If
            
            End If
        Next
    Next

'Let the user know the macro finished running.
MsgBox "The Macro has finished running, you may now work with the PowerPoint Presentation."

Exit Sub

'Handle the No File Error.
noFile:
MsgBox "We Couldn't find the file, exiting the Macro."

End Sub
<strike></strike>
 

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.

Forum statistics

Threads
1,223,950
Messages
6,175,582
Members
452,653
Latest member
craigje92

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top