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