Copy each excel worksheets and paste in each indivual slides

[Djani]

It's indeed becoming quite tricky. However, as always, I really appreciate your help!

I followed your logic and made sure that there weren't any "RangeToCopy1/2" ranges in the sheets that include a chart. The other sheets do have these. However, when I run the query, it gives me the following error: "Selection (unknown member): Invalid request. Nothing approriate is currently selected. I assumed that I had to literally select the charts on the slide, so it could copy-paste them, but unfortunately without result.

Option Explicit
 
Sub PPT()
     
    Dim iName As Long
    Dim rName As Range
    Dim nRange As Long
    Dim dSlideCenter As Double
    Dim pptApp As PowerPoint.Application
    Dim pptPre As PowerPoint.Presentation
    Dim pptSld As PowerPoint.Slide
    Dim objSheet As Worksheet
     
    Set pptApp = CreateObject("PowerPoint.Application")
    Set pptPre = pptApp.Presentations.Add
     
     ' loop the sheets
    For Each objSheet In ActiveWorkbook.Worksheets
         
         'Create new slide for the data
        Set pptSld = pptPre.Slides.Add(pptPre.Slides.Count + 1, ppLayoutBlank)
         
        If WorksheetFunction.Count(objSheet.UsedRange) > 0 Then
             ' Data in sheet so copy used range(s)
             
            For iName = 1 To 2
                 ' initialize
                Set rName = Nothing
                nRange = 0
                 
                 ' look for named range
                On Error Resume Next
                Set rName = objSheet.Range("RangeToCopy" & CStr(iName))
                On Error GoTo 0
                 
                If Not rName Is Nothing Then
                     ' counter
                    nRange = nRange + 1
                     ' copy range as picture
                    rName.CopyPicture Appearance:=xlScreen, Format:=xlPicture
                     ' paste the copied picture
                    pptSld.Shapes.Paste
                     
                     ' Align pasted shape
                    pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
                    pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
                End If
            Next
             
        Else
             ' No data in sheet, so copy chart
            objSheet.ChartObjects(1).Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
             
             ' paste the copied picture
            pptSld.Shapes.Paste
        End If
         
         ' Align pasted shape
        pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
        pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
         
        If nRange = 2 Then
            With pptSld.Shapes(pptSld.Shapes.Count - 1) ' first shape of two
                dSlideCenter = .Left + .Width / 2
                .Left = 1.5 * dSlideCenter - .Width / 2 ' center shape in left half of slide
            End With
            With pptSld.Shapes(pptSld.Shapes.Count) ' last shape of two
                .Left = 1.5 * dSlideCenter + .Width / 2 ' center shape in right half of slide
            End With
        End If
    Next
End Sub

Highlighting the piece of code doesn't work, but it seems to get stuck on this part: pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True.
When it didn't work I have tried to do it with "RangeToCopy1" ranges in the sheets that include charts, but it gives the same error.

Many thanks again.

Yours sincerely,

Djani