Jschroeder
06-06-2016, 11:13 AM
Hi All, I have a piece of code that loops through my workbook and cuts and pastes a range to PowerPoint. What I need to do is have it use Vlookup (or something like that) to see what sheet it is currently on, and lookup the range for that sheet, then use it. My code is below. I've had some help elsewhere with this code so I am by no means and expert or even intermediate.
The other issue is it is creating the slides backwards from the spreadsheet.
Thanks in advance.
J.
Sub LoopThroughSheets()
Dim ws As Worksheet, ppapp As PowerPoint.Application, PPShapeRange As PowerPoint.ShapeRange, _
psheet, pppres, newslide, slideid
Set ppapp = New PowerPoint.Application
ppapp.Visible = True
ppapp.Presentations.Open ("J:\51+Quoting Project\JS Template\2016_Renewal_Report_2.pptm")
With ThisWorkbook.Worksheets("Sheet1")
sTxt1 = .Range("D4").Value
sTxt2 = .Range("D5").Value
End With
With ppapp.ActivePresentation.Slides(1)
.Shapes("TextBox 3").TextFrame.TextRange.Text = sTxt2
'.TextBox 3.Value = Format(sTxt2, "mmmm" "dd", "yyyy")
.Shapes("TextBox 3").TextFrame.TextRange.Text = Format(sTxt2, "mmmm d, yyyy")
.Shapes("TextBox 2").TextFrame.TextRange.Text = sTxt1
End With
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
Set pppres = ppapp.ActivePresentation
Set psheet = ActiveSheet
Set newslide = pppres.Slides(10).Duplicate
With newslide
.Shapes.Title.TextFrame.TextRange.Text = "2016 Renewal – " & psheet.[B41]
.SlideShowTransition.Hidden = msoFalse
.Name = [B42]
End With
slideid = [B42]
psheet.Range("A4:AC32").CopyPicture Appearance:=xlScreen, Format:=xlPicture
' Paste the range and align it
Set PPShapeRange = pppres.Slides(slideid).Shapes.Paste
With PPShapeRange
.Height = 320
.Align AlignCmd:=msoAlignCenters, RelativeTo:=True
.Align AlignCmd:=msoAlignMiddles, RelativeTo:=True
End With
End If
'On Error Resume Next
ws.[B42] = ws.Name
End If
Next ws
Sheets("Sheet1").Activate
MsgBox "Completed Successfully!", vbOKOnly + vbInformation
End Sub
The other issue is it is creating the slides backwards from the spreadsheet.
Thanks in advance.
J.
Sub LoopThroughSheets()
Dim ws As Worksheet, ppapp As PowerPoint.Application, PPShapeRange As PowerPoint.ShapeRange, _
psheet, pppres, newslide, slideid
Set ppapp = New PowerPoint.Application
ppapp.Visible = True
ppapp.Presentations.Open ("J:\51+Quoting Project\JS Template\2016_Renewal_Report_2.pptm")
With ThisWorkbook.Worksheets("Sheet1")
sTxt1 = .Range("D4").Value
sTxt2 = .Range("D5").Value
End With
With ppapp.ActivePresentation.Slides(1)
.Shapes("TextBox 3").TextFrame.TextRange.Text = sTxt2
'.TextBox 3.Value = Format(sTxt2, "mmmm" "dd", "yyyy")
.Shapes("TextBox 3").TextFrame.TextRange.Text = Format(sTxt2, "mmmm d, yyyy")
.Shapes("TextBox 2").TextFrame.TextRange.Text = sTxt1
End With
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
Set pppres = ppapp.ActivePresentation
Set psheet = ActiveSheet
Set newslide = pppres.Slides(10).Duplicate
With newslide
.Shapes.Title.TextFrame.TextRange.Text = "2016 Renewal – " & psheet.[B41]
.SlideShowTransition.Hidden = msoFalse
.Name = [B42]
End With
slideid = [B42]
psheet.Range("A4:AC32").CopyPicture Appearance:=xlScreen, Format:=xlPicture
' Paste the range and align it
Set PPShapeRange = pppres.Slides(slideid).Shapes.Paste
With PPShapeRange
.Height = 320
.Align AlignCmd:=msoAlignCenters, RelativeTo:=True
.Align AlignCmd:=msoAlignMiddles, RelativeTo:=True
End With
End If
'On Error Resume Next
ws.[B42] = ws.Name
End If
Next ws
Sheets("Sheet1").Activate
MsgBox "Completed Successfully!", vbOKOnly + vbInformation
End Sub