Copy ranges from multiple sheets to multiple slides in PPT with the push of a button, halfway there!

[JSchroeder71]

I currently have an Excel Workbook that "semi-manually" generates a PowerPoint presentation. On each page of the spreadsheets I have a button that when clicked copies a range and/or text to a slide in PowerPoint (that it copies from a template). Currently I have to do that for each page in the spreadsheet. What I would like to do is have ONE button i can click to generate the Presentation from all the spreadsheets. I would like it to go through each spreadsheet that is NOT hidden and copy the specified range to a new slide, then move on to the next Spreadsheet and repeat until the end of the Workbook.

I am relatively new to VBA and have gotten this far with a lot of help from this community, I hope you can help me with this step. Current Code is below.

Private Sub CommandButton6_Click()
' Initialize PowerPoint Object Library
        Set PPApp = GetObject(, "Powerpoint.Application")

' Set PPApp = New PowerPoint.Application
            PPApp.Visible = True

' Reference active presentation
        Set PPPres = PPApp.ActivePresentation
        Set psheet = ActiveSheet
        Set newslide = PPPres.Slides(10).Duplicate
 'Set newslide = PPPres.Slides(11)
             With newslide
             .Shapes.Title.TextFrame.TextRange _
             .Text = "2016 Renewal – " & ActiveSheet.Range("B41")
             .Name = psheet.Range("B41")
             .SlideShowTransition.Hidden = msoFalse
             End With


             SlideID = psheet.Range("B42")


' Copy the range as a picture
               ActiveSheet.Range("A4:N33").CopyPicture Appearance:=xlScreen, Format:=xlPicture
' Paste the range and align it
        Dim PPShapeRange As PowerPoint.ShapeRange
        Set PPShapeRange = PPPres.Slides(SlideID).Shapes.Paste
            With PPShapeRange
                .Height = 324
                .Align AlignCmd:=msoAlignCenters, RelativeTo:=True
                .Align AlignCmd:=msoAlignMiddles, RelativeTo:=True
            End With


' this is the message box to notify when done.
                answer = MsgBox("The operation has completed successfully! Would you like to view the slide?", vbYesNo + vbQuestion, "Empty Sheet")
            If answer = vbYes Then

                Set PPApp = GetObject(, "PowerPoint.Application")
                With PPApp
                    .Activate
                    .ActivePresentation.Slides(SlideID).Select
                End With
                     Else
'do nothing
            End If
End Sub

I should mention the way I am currently doing it I have to start with the last spreadsheet and work my way forward (5,4,3,2,1) so the presentation slides are in the correct order (1,2,3,4,5). I'm not sure how to correct this.

Thanks in advance,
John

 

[JSchroeder71]

OK so I have received no replies but I have made some progress.

It is to the point where it creates the slides and names them properly, however it is not copying the ranges or charts and it is creating the slides backwards, 5,4,3,2,1, instead of 12,3,4,5. any help would be great!
My most recent code is below.

Sub LoopThroughSheets()

Application.ScreenUpdating = False

    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
     If ws.Name = "Sheet1" Or ws.Name = "sheet2" Then
'do nothing
    Else
        If ws.Visible = True Then
        ws.Activate
' 'Start copy charts

         Set PPApp = New PowerPoint.Application
             PPApp.Visible = True
          
                 
'Reference active presentation
         Set PPPres = PPApp.ActivePresentation
         Set psheet = ActiveSheet
         Set newslide = PPPres.Slides(10).Duplicate
              With newslide
              .Shapes.Title.TextFrame.TextRange _
              .Text = "2016 Renewal – " & ActiveSheet.Range("B41")
              .SlideShowTransition.Hidden = msoFalse
              End With
        
              SlideID = Cells(42, B)
              
                

'  Copy the range as a picture
                ActiveSheet.Range("A4:AC32").CopyPicture Appearance:=xlScreen, Format:=xlPicture

'  Paste the range and align it
         Dim PPShapeRange As PowerPoint.ShapeRange
         Set PPShapeRange = PPPres.Slides(SlideID).Shapes.Paste
             With PPShapeRange
                 .Height = 324
                 .Align AlignCmd:=msoAlignCenters, RelativeTo:=True
                 .Align AlignCmd:=msoAlignMiddles, RelativeTo:=True
             End With
        End If
       
        On Error Resume Next
        ws.Range("B42") = ws.Name
         
       
      End If
    Next ws
    
    Application.ScreenUpdating = True
    
    Sheets(Sheet1).Activate
    
End Sub

 

[Theeeffect]

How did this work out for you? I can't contribute - but I am realizing the same problem as of now.

- Did you ever solve it?


Best regards,

Eric