Hi Everyone, I've done as much of this as I can on my own (and with help from people much smarter than I). I'm a VBA Newbie.
I have an Excel spreadsheet that creates a PowerPoint Presentation. By clicking a button on each sheet, it copies a range or chart to the Presentation (thats currently open) as a picture and adds a title to the slide. This works but...
What I'm trying to do is get it down to just clicking one button and it loops through each sheet that is not hidden, copies the chart and the title and pastes it to a new Slide in PowerPoint without having to go to each sheet and click a button. Kind of like a "Generate PowerPoint" button.
I have gotten it to the point where it loops through and titles each page, but it wont copy the ranges/charts and it places them in backwards, 5,4,3,2,1 instead of 1,2,3,4,5. I'm not sure where the problem lies.
Any help would be great!
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
MsgBox "Completed Successfully!"
End Sub
Thanks,
John
Bookmarks