You forgot to activate each of the sheets.
But basically, you do not have to activate them. You do not need to select cells too. :-)
Note how I designate the scope of the table to be copied. I download the cell that contains the top left corner of the image, then move it one row down and one column to the right. and then I designate CurrentRegion. This shift to the right is only a safeguard in case the image goes left beyond the edge of the table.
Sub CPAT_ExcelToPowerPoint_1() '***** THIS IS THE CORRECT CODE TO USE FOR COPYING CPAT FROM EXCEL TO POWERPOINT *************************
'Declare variables
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim SlideCount As Integer
Dim myShp As Excel.Shape
Dim slTitle As String
Dim mySht As Excel.Worksheet
Dim Rng As Excel.Range
'Start a new instance of Powerpoint
Set PPApp = New PowerPoint.Application
PPApp.Visible = True
'Create new ppt
Set PPPres = PPApp.Presentations.Add
For Each mySht In ActiveWorkbook.Worksheets
If mySht.Name <> "Definition and Filter" And _
mySht.Name <> "Performance Summary" And _
mySht.Name <> "Perf Summary no Charts" Then
'mysht.Activate
'Loop through all the pictures on the sheet. Select picture, copy it
For Each myShp In mySht.Shapes
If LCase(myShp.Name) Like "picture*" Then
myShp.CopyPicture Appearance:=xlScreen, Format:=xlPicture
'DoEvents 'This line is added so that Excel has time to complete the copy/paste operation
'Create New Slide
Set PPSlide = PPPres.Slides.Add(PPPres.Slides.Count + 1, ppLayoutTitleOnly)
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex ' activate the slide
'Setting the slide title variable, based on the worksheet name
slTitle = mySht.Name
'Paste the picture in the newly created slide
PPApp.ActiveWindow.View.Paste
'DoEvents
'Select first region of data
Set Rng = myShp.TopLeftCell.Offset(1, 1).CurrentRegion
'ActiveCell.CurrentRegion.Select
Rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
'DoEvents
'Paste the data in the newly created slide
PPApp.ActiveWindow.View.Paste
'DoEvents
'Add the title to the slide
PPSlide.Shapes.Title.TextFrame.TextRange.Text = slTitle
'DoEvents
End If
Next myShp
End If
Next mySht
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub
The second version of the macro copies the tables with the image and, as a whole, pastes it into the PP. Before copying, all images are centered relative to their tables.
Sub CPAT_ExcelToPowerPoint_2()
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim SlideCount As Integer
Dim myShp As Excel.Shape
Dim slTitle As String
Dim mySht As Excel.Worksheet
Dim Rng As Excel.Range
Call CenteringCharts
Set PPApp = New PowerPoint.Application
PPApp.Visible = True
Set PPPres = PPApp.Presentations.Add
For Each mySht In ActiveWorkbook.Worksheets
If mySht.Name <> "Definition and Filter" And _
mySht.Name <> "Performance Summary" And _
mySht.Name <> "Perf Summary no Charts" Then
For Each myShp In mySht.Shapes
If LCase(myShp.Name) Like "picture*" Then
Set PPSlide = PPPres.Slides.Add(PPPres.Slides.Count + 1, ppLayoutTitleOnly)
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
slTitle = mySht.Name
Set Rng = myShp.TopLeftCell.CurrentRegion
'Copy Picture with its table
Rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
PPApp.ActiveWindow.View.Paste
PPSlide.Shapes.Title.TextFrame.TextRange.Text = slTitle
End If
Next myShp
End If
Next mySht
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub
Sub CenteringCharts()
Dim wks As Worksheet
Dim shp As Shape
Dim Lft As Single
Dim Wdth As Single
Dim Rng As Range
For Each wks In ActiveWorkbook.Worksheets
For Each shp In wks.Shapes
If LCase(shp.Name) Like "picture*" Then
Set Rng = shp.TopLeftCell.Offset(, 1).CurrentRegion
Wdth = Rng.Width
With Rng
Lft = .Left + (.Width - shp.Width) / 2
End With
shp.Left = Lft
End If
Next shp
Next wks
End Sub
Sub AlignToLeftCharts()
Dim wks As Worksheet
Dim shp As Shape
Dim Rng As Range
For Each wks In ActiveWorkbook.Worksheets
For Each shp In wks.Shapes
If LCase(shp.Name) Like "picture*" Then
Set Rng = shp.TopLeftCell.Offset(, 1).CurrentRegion
shp.Left = Rng.Left
End If
Next shp
Next wks
End Sub
Artik