VBA to copy all Print_area to powerpoint

[MuppetReaper]

Hi all

I'm after some code that will loop through each worksheet in an excel document and copy the Print_Area from each to a new page in a PowerPoint presentation as Enhanced Metafile picture, I ideally I would like it to be generic enough to not have to name the sheets in the code as I would use this on multiple workbooks.

e.g.- excel has 6 tabs that have Print_area defined, so each of those tabs becomes a separate page in PP

It would also need to set the size to match exactly the page in PP.

I have had codes in the past to do this kind of thing, but I had to name individual tabs and ranges etc.

Many thanks in advance.

 

[MuppetReaper]

Also, if a worksheet does not have a defined Print_area it needs to skip that and move to the next
Most of the workbooks I'm using have several sheets with Print_area defined, then some at the end that do not

 

[MuppetReaper]

managed to cobble this together, might not be the most elegant code, but seems to work if anyone wants to use it

Sub PasteToPowerPoint()


'PURPOSE: Copy Excel Ranges defined as "Print_Area" and Paste them into the Active PowerPoint presentation slides
'Will skip worksheets with no defined Print_area
'Will resize pictures to fit PP slides


    Dim myPresentation As Object
    Dim PowerPointApp As Object
    Dim shp As Object
    Dim objSheet As Worksheet
    
    SaveTo = ActiveWorkbook.Path
    ExcelName = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 10)
    
    
    'Create an Instance of PowerPoint
    On Error Resume Next
        
    'Is PowerPoint already opened?
    Set PowerPointApp = GetObject(Class:="PowerPoint.Application")
        
    'Clear the error between errors
    Err.Clear
    
    'create a new PowerPoint
    If PowerPointApp Is Nothing Then
        Set PowerPointApp = New PowerPoint.Application
    End If
    'Make a presentation in PowerPoint
    If PowerPointApp.Presentations.Count = 0 Then
        PowerPointApp.Presentations.Add
    End If
              
    'Show the PowerPoint
    PowerPointApp.Visible = True
        
    'Handle if the PowerPoint Application is not found
    If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
    End If
    
    On Error GoTo 0
          
    'Make PowerPoint Visible and Active
    PowerPointApp.ActiveWindow.Panes(1).Activate
            
    'Create a New Presentation
    Set myPresentation = PowerPointApp.ActivePresentation
    
    'loop the sheets
    For Each objSheet In ActiveWorkbook.Worksheets
        objSheet.Activate
        On Error Resume Next
        If objSheet.Range("Print_Area") Is Nothing Then
            GoTo tag1
        Else
        If objSheet.Visible = xlSheetVisible Then
            objSheet.Range("Print_Area").Copy
            'Create new slide for the data
            Set pptSld = myPresentation.Slides.Add(myPresentation.Slides.Count + 1, ppLayoutBlank)
            'paste the copied picture
            Set shp = pptSld.Shapes.PasteSpecial(DataType:=2)
            With myPresentation.PageSetup
                shp.Left = 0
                shp.Top = 0
                shp.LockAspectRatio = msoFalse
                shp.Width = (25.4 * 283 / 10)
                shp.Height = (19 * 283 / 10) '283=10cm
            End With
            Application.CutCopyMode = False
        End If
    End If
                   
                
tag1:
    Next
            
    Date1 = Format(Date, "yyyymmdd")
    myPresentation.SaveAs Filename:=SaveTo & "\" & ExcelName & Date1 & "_v1 0.pptx"
    
    Application.CutCopyMode = False
    ThisWorkbook.Activate




End Sub