Copy/paste from Excel to PowerPoint - Not looping properly

[ajjava]

I have cobbled together the code below, which is meant to:

• loop through many worksheets and for each picture found...
• copy/paste picture to newly created, individual PPT slides.
• copy/paste corresponding data table (located beneath picture) to the SAME individual newly created PPT slide
• make slide title same as worksheet
• repeat for each picture on a worksheet
• repeat for all worksheets in workbook (except several excluded worksheets)

I got the code to work perfectly - as long as I was limiting it to run on just ONE worksheet.
When I add the loop to go through ALL the worksheets, things fall apart.

My sense is that it's because I'm using .Select (which I know is a no-no, but was the only way I could come up with to accomplish my goal) and because perhaps I've screwed up with declaring/usage of some variables.



I'm attaching the source Excel file and a sample of the desired outcome in PowerPoint.

The code is missing the necessary commands to position and resize the pictures. I'll tackle that next.

Also, if there are ways to improve the code, please do feel free to educate me. Since I'm fairly new to VBA, I'm still very literal in my English-to-VBA commands. I know that's rarely best practice, however.

The code:

Sub CPAT_ExcelToPowerPoint() '*****  THIS IS THE CORRECT CODE TO USE FOR COPYING CPAT FROM EXCEL TO POWERPOINT   *************************

'Add a reference to the Microsoft PowerPoint Library by:
    '1. Go to Tools in the VBA menu
    '2. Click on Reference
    '3. Scroll down to Microsoft PowerPoint X.0 Object Library, check the box, and press Okay
 
'Things left to do:
    '1.  Loop through all worksheets
    '2.  Resize/reposition the pictures
    '3.  Add the text boxes on each slide
    '4.  Make sure blank cells are addresed before copy/paste
    '5.  Will any columns need to be resized before copy/paste? I don't think so, because of Jill's work in BO, but need to check
    '6.  Change slide titles to be the same as the corresponding Excel worksheet
    
    
    
'Declare variables
        
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim SlideCount As Integer
Dim myShp As Shape
Dim slTitle As String
'Dim mysht As Worksheet


'Start a new instance of Powerpoint
Set PPApp = New PowerPoint.Application
PPApp.Visible = True




'Create new ppt
Set PPPres = PPApp.Presentations.Add
    


        


        'Make sure the correct starting cell is selected in Excel, so that the 'CurrentRegion' selection will work
        Range("A2").Select
        
                
            'Loop through all the pictures on the sheet. Select picture, copy it
            For Each Shape In ActiveSheet.Shapes
               
               If Left(Shape.Name, 7) = "Picture" Then
                    Shape.CopyPicture Appearance:=xlScreen, Format:=xlPicture
                End If
                
                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 = ActiveSheet.Name
              
              'Paste the picture in the newly created slide
              PPApp.ActiveWindow.View.Paste
              DoEvents
               
              'Select first region of data
              ActiveCell.CurrentRegion.Select
              Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
              DoEvents
              
              'Paste the data in the newly created slide
              PPApp.ActiveWindow.View.Paste
              DoEvents
              
              'Select next region of data
              Selection.End(xlToRight).Select
              Selection.End(xlToRight).Select
              
           
              'Add the title to the slide
              PPSlide.Shapes.Title.TextFrame.TextRange.Text = slTitle
                
            Next Shape






Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
    
     
End Sub