I am basically looking for a way to trim below code. Code works just fine. This code takes a range from each tab of excel and paste it into powerpoint and then assigns a title to each slide after pasting, but I feel the code is way too long and can be trimmed. I use excel 2016. Also worth mentioning that everywhere it says repeat, it is basically repeating the copy and paste from excel tab to powerpoint then assigning a title to that slide.
Sub CommercialtoPowerPoint()
'declare variables
Dim otherWB As Workbook
Dim ws As Worksheet
Dim PP As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPslide As PowerPoint.Slide
Dim Sh As PowerPoint.Shape
Dim Bh As PowerPoint.Shape
Dim GSF As Workbook
Dim SlideTitle As String
'opening powerpoint and creating a new presentation
Set GSF = Workbooks("Support Function P&L Details FY23-Update File")
Set PP = New PowerPoint.Application
Set PPPres = PP.Presentations.Add
PP.Visible = True
'adding new slide to PP presentation and using for further use
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPslide.Select
'setting slide size from 16:9 to 4:3
PPslide.Application.ActivePresentation.PageSetup.SlideSize = 1 'ppSlideSizeOnScreen = 1
'code to copy range from excel sheet
Sheets("Commercial-H1").Select
Sheets("Commercial-H1").Range("B3:L220").Copy
'pasting picture and adjusting positing
With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
.Width = 666.72
.Height = 390.24
End With
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
Application.CutCopyMode = False
'Adding title to slide and align center
SlideTitle = "H1 P&L"
PPslide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = Arial
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
Application.CutCopyMode = False
'repeat
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPslide.Select
Sheets("Commercial-LAM").Select
Sheets("Commercial-LAM").Range("B3:L220").Copy
With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
.Width = 666.72
.Height = 390.24
End With
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
Application.CutCopyMode = False
SlideTitle = "LAM P&L"
PPslide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = Arial
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
Application.CutCopyMode = False
'repeat
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPslide.Select
Sheets("Commercial-EMEA").Select
Sheets("Commercial-EMEA").Range("B3:L220").Copy
With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
.Width = 666.72
.Height = 390.24
End With
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
Application.CutCopyMode = False
SlideTitle = "EMEA P&L"
PPslide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = Arial
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
Application.CutCopyMode = False
'repeat
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPslide.Select
Sheets("Commercial-APAC").Select
Sheets("Commercial-APAC").Range("B3:L220").Copy
With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
.Width = 666.72
.Height = 390.24
End With
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
Application.CutCopyMode = False
SlideTitle = "APAC P&L"
PPslide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = Arial
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
Application.CutCopyMode = False
'repeat
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPslide.Select
Sheets("Commercial-HS Admin").Select
Sheets("Commercial-HS Admin").Range("B3:L220").Copy
With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
.Width = 666.72
.Height = 390.24
End With
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
Application.CutCopyMode = False
SlideTitle = "HS Admin P&L"
PPslide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = Arial
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
Application.CutCopyMode = False
'repeat
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPslide.Select
Sheets("Commercial-Corp").Select
Sheets("Commercial-Corp").Range("B3:L220").Copy
With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
.Width = 666.72
.Height = 390.24
End With
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
Application.CutCopyMode = False
SlideTitle = "Corp P&L"
PPslide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = Arial
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
Application.CutCopyMode = False
'repeat
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPslide.Select
Sheets("Commercial-all").Select
Sheets("Commercial-all").Range("B3:L220").Copy
With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
.Width = 666.72
.Height = 390.24
End With
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
Application.CutCopyMode = False
SlideTitle = "Full P&L"
PPslide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = Arial
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
Application.CutCopyMode = False
'Adding slide for Headcount and moving to last slide
Dim slideCount As Long
slideCount = PPPres.Slides.Count
Set PPslide = PPPres.Slides.Add(slideCount + 1, ppLayoutTitleOnly)
PPslide.Select
PPslide.Shapes(1).TextFrame.TextRange.Text = "Headcount"
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = Arial
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
'setting powerpoint title
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitle)
PPslide.Select
PPslide.Shapes(1).TextFrame.TextRange.Text = "Monthly P&L Report"
PPslide.Shapes(2).TextFrame.TextRange.Text = "Commercial"
'back to excel sheet and select cell A1 in every sheet
GSF.Activate
Application.CutCopyMode = False
For Each ws In GSF.Sheets
ws.Activate
ws.[a1].Select
Next ws
GSF.Worksheets(1).Activate
'powerpoint memory cleanup
PP.Activate
Set PPslide = Nothing
Set PPPres = Nothing
Set PP = Nothing
Set Sh = Nothing
Set Bh = Nothing
Set GSF = Nothing
End Sub
I took some bits and pieces and trimmed them, but I feel there is room for more.
This new version of the code uses two arrays, one for the sheet names and another one for the slide titles. It also uses a loop to iterate through the sheets and titles. This way, you don't need to repeat the same code multiple times.
Also removed the unused variables and made the font name a string.
Sub CommercialtoPowerPoint()
'declare variables
Dim PP As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPslide As PowerPoint.Slide
Dim Sh As PowerPoint.Shape
Dim slideTitle As String
'opening powerpoint and creating a new presentation
Set PP = New PowerPoint.Application
Set PPPres = PP.Presentations.Add
PP.Visible = True
'setting slide size from 16:9 to 4:3
PPPres.PageSetup.SlideSize = 1
'Array of sheet names
Dim sheetNames() As String
sheetNames = Array("Commercial-H1", "Commercial-LAM", "Commercial-EMEA")
'Array of slide titles
Dim slideTitles() As String
slideTitles = Array("H1 P&L", "LAM P&L", "EMEA P&L")
'loop through the sheets
For i = 0 To UBound(sheetNames)
'adding new slide to PP presentation and using for further use
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPslide.Select
'code to copy range from excel sheet
Sheets(sheetNames(i)).Range("B3:L220").Copy
'pasting picture and adjusting positing
With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
.Width = 666.72
.Height = 390.24
End With
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
'Adding title to slide and align center
slideTitle = slideTitles(i)
PPslide.Shapes.Title.TextFrame.TextRange.Text = slideTitle
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = "Arial"
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
Next i
Application.CutCopyMode = False
End Sub
I figured it out. #German code is good, but needs 2 changes below:
Declare (this was missing)
Dim i As Integer
and change 2 lines below
Dim sheetNames() As String
This needs to be
Dim sheetNames() As Variant
and
Dim slideTitles() As String
needs to be
Dim slideTitles() As Variant
Minor correction and this solved the problem!
Related
I am extracting a excel table as png file the extraction is ok, but the extracted file is too zoomed out and when i zoom in it is all blurr, i am going to attach the image in a mail so the data should be clear visible,Any idea where to change the code ,changed the width and height below to almost 50 no change
With ChTemp.Parent
.Width = PicTemp.Width + 8
.Height = PicTemp.Height + 8
Here is the code
Sub check(filename As String, picturename As String)
Dim myWb As Workbook
Dim ws As Worksheet
Dim i, j As Long, LastRow As Integer
'Dim filename As String, picturename As String
Set myWb = Workbooks.Open(filename:=filename)
Worksheets("Sheet1").Activate
Dim FName As String
FName = picturename
Dim pic_rng As Range
Dim ShTemp As Worksheet
Dim ChTemp As Chart
Dim PicTemp As Picture
Application.ScreenUpdating = False
Set pic_rng = ActiveSheet.Range("A2:N42")
Set ShTemp = Worksheets.Add
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name
Set ChTemp = ActiveChart
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ChTemp.Paste
Set PicTemp = Selection
With ChTemp.Parent
.Width = PicTemp.Width + 8
.Height = PicTemp.Height + 8
End With
ChTemp.Export filename:=picturename, FilterName:="jpg"
'UserForm1.Image1.Picture = LoadPicture(FName)
Kill FName
Application.DisplayAlerts = False
ShTemp.Delete
myWb.Close False
End Sub
The selection in your case is the Chart itself, and nothing will be increase n its dimensions. And the code must paste the picture in the increased chart... Otherwise, any increase does not help.
Try the next way, please:
'what you have in your code...
'.....
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With ChTemp.Parent
.Width = rng.Width + 10
.Height = rng.Height + 10
End With
ChTemp.Paste
ChTemp.Export filename:=picturename, FilterName:="jpg"
'your code...
'...
Currently taking data from an Excel table and inputting it into Powerpoint slides. How could I resize the text below from the table? Powerpoint currently autosizes it to font size 18.
Set ppSlide = ppPres.Slides.Add(1, ppLayoutBlank)
ppSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, 200, 150).TextFrame.TextRange.Characters = "TEST " & Cells(Row, col + 1)
Thank you for any and all help!
You can use '~TextRange.Charaters.' But it is usually used to change some part of a text.
~ TextRange.Characters(1, 2).Font.Bold = True ' sets the font of first 2 letters to bold style
Instead, '~.TextRange' or '~.TextRange.Text' would be just good enough.
And the size of a text can be set with '~ TextRange.Font.Size = xx'
After applying Mathieu Guindon's advice, your code would look like this:
Sub test()
Dim Sht As Worksheet
Dim ppPres As PowerPoint.Presentation
Dim ppSlide As PowerPoint.Slide
Dim ppShape As PowerPoint.Shape
Set Sht = ThisWorkbook.Worksheets("Sheet1")
Set ppPres = ActivePresentation
Set ppSlide = ppPres.Slides.Add(1, ppLayoutBlank)
Set ppShape = ppSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, 200, 150)
With ppShape
.Name = "MyShape 1"
With .TextFrame.TextRange
.Text = "Test" & Sht.Cells(xRow, xColumn + 1) ' "Excel Cell Value"
.Font.Size = 15
.Font.Name = "Arial"
.Font.Bold = True
.Font.Color.RGB = RGB(0, 125, 255)
'change first 2 letters to red color
.Characters(1, 2).Font.Color.RGB = rgbRed
End With
End With
End Sub
Please give a name to Powerpoint shape object, so that you can control the object later by using its name like '~.Shapes("Given name").Textframe.TextRange.~ = ~ '
I am creating a powerpoint from the VBA editor and when I create the individual slides, it works great. However, when I try to create them all at once, PowerPoint crashes. I clear memory by setting Application.CutCopyMode=False at the end of each slide and have Application.Wait for 7 seconds.
My powerpoint is going to be about 25 slides and its already crashing past slide 7. Usually it crashes when I am formatting. I have added in the 3 basic layouts for each Macro I use and slides 8 and 9 of where it crashes.
The First Macro I use copies a slide from last presentation and
pastes to new powerpoint.
The Second Pastes a Table
The Third Pastes a Table, Chart, and Picture (only slide with Picture, otherwise slides of this type paste a table and chart only).
Code:
Sub CreateNewPresentation()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim slidesCount As Long
If ppApp Is Nothing Then
Set ppApp = New PowerPoint.Application
End If
Set ppPres = ppApp.Presentations.Add
ppPres.SaveAs "FileName"
ppApp.Visible = True
slidesCount = ppPres.Slides.Count
Call create_Slide1(slidesCount, ppPres, ppApp)
slidesCount = ppPres.Slides.Count
Application.CutCopyMode = False
Call create_Slide2(slidesCount, ppPres)
slidesCount = ppPres.Slides.Count
Application.CutCopyMode = False
Call create_Slide3(slidesCount, ppPres)
slidesCount = ppPres.Slides.Count
Application.CutCopyMode = False
ppPres.Save
ppPres.Close
Call create_Slide8(slidesCount, ppPres)
slidesCount = ppPres.Slides.Count
Application.CutCopyMode = False
Call create_Slide9(slidesCount, ppPres)
slidesCount = ppPres.Slides.Count
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
sub Create_Slide1(sldNum As Long, ppPrez As PowerPoint.Presentation, ppt As PowerPoint.Application)
Dim myFile As String
Dim ppSlide As PowerPoint.Slide
Dim objPres As PowerPoint.Presentation
Set ppSlide = ppPrez.Slides.Add(sldNum + 1, ppLayoutBlank)
ppPrez.PageSetup.SlideSize = ppSlideSizeLetterPaper
myFile:"File name and path....."
Set objPres=ppt.Presentations.Open(myFile)
objPres.Slides(1).Copy
ppPrez.Slides.Paste Index:=sldNum+1
objPres.Close
ppPrez. Slides(sldNum+2).Delete
End Sub
Sub create_Slide2(sldNum As Long, ppPrez As PowerPoint.Presentation)
Dim ppSlide As PowerPoint.Slide
Set ppSlide = ppPrez.Slides.Add(sldNum + 1, ppLayoutBlank)
ppPrez.PageSetup.SlideSize = ppSlideSizeLetterPaper
ppSlide.Select
ThisWorkbook.Worksheets("Sheet2").Activate
ActiveSheet.Range(Cells(3, 2), Cells(27, 11)).Copy
ppSlide.Shapes.Paste.Select
With ppSlide.Shapes(1)
.Top = ppPrez.PageSetup.SlideHeight / 20
.Left = ppPrez.PageSetup.SlideWidth / 20
.Height = 17 * (ppPrez.PageSetup.SlideHeight) / 20
.Width = 9 * (ppPrez.PageSetup.SlideWidth / 10)
End With
End Sub
sub create_Slide3(sldNum As Long, ppPrez As PowerPoint.Presentation)
Dim ppSlide As PowerPoint.Slide
Dim ppTextBox As PowerPoint.Shape
Set ppSlide = ppPrez.Slides.Add(sldNum + 1, ppLayoutBlank)
ppPrez.PageSetup.SlideSize = ppSlideSizeLetterPaper
ppSlide.Select
Set ppTextBox = ppSlide.Shapes.AddTextbox( _
msoTextOrientationHorizontal, 0, 15, ppPrez.PageSetup.SlideWidth, 60)
With ppTextBox.TextFrame
.TextRange.Text = "Slide3"
.TextRange.ParagraphFormat.Alignment = ppAlignCenter
.TextRange.Font.Size = 20
.TextRange.Font.Name = "Calibri"
.VerticalAnchor = msoAnchorMiddle
End With
ThisWorkbook.Sheets("Sheet3").Activate
ActiveSheet.Range(Cells(17, 10), Cells(19, 19)).Copy
ppSlide.Shapes.Paste.Select
With ppSlide.Shapes(2)
.Width = (6 / 10) * ppPrez.PageSetup.SlideWidth
.Left = (1 / 40) * ppPrez.PageSetup.SlideWidth
.Top = (5 / 8) * ppPrez.PageSetup.SlideHeight
End With
Sheets("Sheet3").Shapes("Shape1").CopyPicture
ppSlide.Shapes.Paste
ppSlide.Shapes(4).Height = 850
ppSlide.Shapes(4).Width = 275
ppSlide.Shapes(4).Left = (6.2 / 10) * ppPrez.PageSetup.SlideWidth
ppSlide.Shapes(4).Top = (1 / 10) * ppPrez.PageSetup.SlideHeight
End sub
sub create_Slide8(sldNum As Long, ppPrez As PowerPoint.Presentation)
Dim ppSlide As PowerPoint.Slide
Set ppSlide = ppPrez.Slides.Add(sldNum + 1, ppLayoutBlank)
ppPrez.PageSetup.SlideSize = ppSlideSizeLetterPaper
ppSlide.Select
ThisWorkbook.Sheets("roll").Activate
ActiveSheet.ChartObjects("35").Activate
ActiveChart.ChartArea.Copy
ppSlide.Shapes.Paste.Select
With ppSlide.Shapes(1)
.Left = 1 * (ppPrez.PageSetup.SlideWidth / 20)
.Height = _
ppPrez.PageSetup.SlideHeight / 2
.Width = _
9 * (ppPrez.PageSetup.SlideWidth / 10)
.Top = 0
End With
Application.Wait (Now + TimeValue("0:00:03"))
Application.CutCopyMode = False
MsgBox ("done")
ActiveSheet.ChartObjects("40").Activate
ActiveChart.ChartArea.Copy
ppSlide.Shapes.Paste.Select
With ppSlide.Shapes(2)
.Left = 1 * (ppPrez.PageSetup.SlideWidth / 20)
.Height = _
ppPrez.PageSetup.SlideHeight / 2
.Width = _
9 * (ppPrez.PageSetup.SlideWidth / 10)
.Top = _
ppPrez.PageSetup.SlideHeight / 2
End With
Application.Wait (Now + TimeValue("0:00:07"))
MsgBox ("done")
End Sub
sub create_Slide9(sldNum As Long, ppPrez As PowerPoint.Presentation, ppt As PowerPoint.Application)
Dim ppSlide As PowerPoint.Slide
Dim objPres As PowerPoint.Presentation
Set ppSlide = ppPrez.Slides.Add(sldNum + 1, ppLayoutBlank)
ppPrez.PageSetup.SlideSize = ppSlideSizeLetterPaper
ppSlide.Select
myFile = "File Path....same as above"
Set objPres = ppt.Presentations.Open(myFile)
objPres.Slides(8).Copy
ppPrez.Slides.Paste Index:=sldNum + 1 'sometimes it fails here too because of a paste issue (Either vba doesn't like method or no where to paste too)
objPres.Close
ppPrez.Slides(sldNum + 2).Delete
MsgBox ("done")
Application.Wait (Now + TimeValue("0:00:07"))
End Sub
I'm not certain, but I think that message boxes are blocking. Execution is stopped until it's dealt with, so wont give your code time to recover.
The following code should work but I don't really like it. Its the best I can do without modifying some of your other functioning code too.
Hopefully you might see what the idea behind the code is and can improve on it.
Ideally it would use a loop and be inside your CreateNewPresentation sub instead of a recursive function.
You could potentially just replace the messageboxes in your code with Sleep 100 and not use my code (after copying the Sleep Declaration to your module)
PowerPoint doesn't have a ScreenUpdating type deal and some commands do take a while to complete. Using Sleep between each slide may help, it might not. It might be worth putting some Sleep's between some function calls in your create_slideN macros. I've never automated Powerpoint so dont know how it works.
Private Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
Public CreationIndex As Integer
Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim slideCount As Integer
Sub CreateNewPresentation()
Application.ScreenUpdating = False
Application.EnableEvents = False
If ppApp Is Nothing Then
Set ppApp = New PowerPoint.Application
End If
Set ppPres = ppApp.Presentations.Add
ppPres.SaveAs "FileName"
ppApp.Visible = True
CreationIndex = 1
Create CreationIndex ' start the ball rolling...
End Sub
Sub Create(i As Integer)
slidesCount = ppPres.Slides.Count
Select Case i
Case 1
Call Create_Slide1(slidesCount, ppPres, ppApp)
Case 2
Call create_Slide2(slidesCount, ppPres)
Case 3
Call create_Slide3(slidesCount, ppPres)
Case Else
MsgBox "Complete or Broken...", vbOKOnly
Exit Sub
End Select
Application.CutCopyMode = False
Sleep 200 ' wait for a bit...
CreationIndex = CreationIndex + 1
Create CreationIndex
End Sub
Hello I am try to copy an image from excel into powerpoint. My code already copy and pastes into excel but I am having an issue with the code that would automate the resizing. With this current code I get object required Runtime error 424. Any help would be appreciated. MY abbreviated code is below.
Sub CopyDataToPPT()
'Const ppLayoutBlank = 12
Dim objWorkSheet As Worksheet
Dim objRange As Range
Dim objPPT As PowerPoint.Application
Dim objPresentation As Presentation
Dim shapePPTOne As Object
Dim intLocation As Integer
Dim intHeight As Integer
Dim inLayout As Integer
Dim strRange As String
Dim boolOK As Boolean
Set objPPT = CreateObject("PowerPoint.Application")
Set objPresentation = objPPT.Presentations.Add
'First 1 Xor 2 charts
If Sheets("Summary Table").Cells(15, 4) <> "Not Found" Then
strRange = "B4:N24"
intHeight = 380
Else
strRange = "B4:N13"
intHeight = 190
End If
Set objslide = objPresentation.Slides.Add(1, inLayout)
objPresentation.Slides(1).Layout = ppLayoutTitleOnly
objPresentation.Slides(1).Shapes.Title.TextFrame.TextRange.Text = Sheets("Summary Table").Cells(2, 5) & " - " & Sheets("Summary Table").Cells(4, 2)
Set objRange = Sheets("Summary Table").Range(strRange)
objRange.Copy
DoEvents
Set shapePPTOne = objslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile, Link:=msoFalse)
shapePPTOne.Height = intHeight
shapePPTOne.Left = 50
shapePPTOne.Top = 100
Application.CutCopyMode = False
Next intLocation
This (a simplified version of your code) works fine for me:
Sub CopyDataToPPT()
Dim objslide
Dim objRange As Range
Dim objPPT As PowerPoint.Application
Dim objPresentation As Presentation
Dim shapePPTOne As Object
Set objPPT = CreateObject("PowerPoint.Application")
Set objPresentation = objPPT.Presentations.Add
Set objslide = objPresentation.Slides.Add(1, ppLayoutTitleOnly) 'you had inLayout???
objslide.Shapes.Title.TextFrame.TextRange.Text = "blah blah"
Sheets("Sheet1").Range("C6:G22").Copy
DoEvents
Set shapePPTOne = objslide.Shapes.PasteSpecial( _
DataType:=ppPasteEnhancedMetafile, Link:=msoFalse)
With shapePPTOne
.Height = 200
.Left = 50
.Top = 100
End With
Application.CutCopyMode = False
End Sub
I'm trying to create an excel macro that copies charts displayed on an excel sheet, and pastes them (paste special) into a PowerPoint. The problem I'm having is how do I paste each chart on a different slide? I do not know the syntax at all..
This is what I have so far (it works but it only pastes to the first sheet):
Sub graphics3()
Sheets("Chart1").Select
ActiveSheet.ChartObjects("Chart1").Activate
ActiveChart.ChartArea.Copy
Sheets("Graphs").Select
range("A1").Select
ActiveSheet.Paste
With ActiveChart.Parent
.Height = 425 ' resize
.Width = 645 ' resize
.Top = 1 ' reposition
.Left = 1 ' reposition
End With
Dim PPT As Object
Set PPT = CreateObject("PowerPoint.Application")
PPT.Visible = True
PPT.Presentations.Open Filename:="locationwherepptxis"
Set PPApp = GetObject("Powerpoint.Application")
Set PPPres = PPApp.activepresentation
Set PPSlide = PPPres.slides _
(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
' Copy chart as a picture
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
Format:=xlPicture
' Paste chart
PPSlide.Shapes.Paste.Select
' Align pasted chart
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
Given I dont have your file locations to work with I have attached a routine below that
Created a new instance of PowerPoint (late binding, hence the need to define constants for ppViewSlide etc)
Loops through each chart in a sheet called Chart1 (as per your example)
Adds a new slide
Pastes each chart, then repeats
Did you need to format each chart picture before exporting for size, or can you change your default chart size?
Const ppLayoutBlank = 2
Const ppViewSlide = 1
Sub ExportChartstoPowerPoint()
Dim PPApp As Object
Dim chr
Set PPApp = CreateObject("PowerPoint.Application")
PPApp.Presentations.Add
PPApp.ActiveWindow.ViewType = ppViewSlide
For Each chr In Sheets("Chart1").ChartObjects
PPApp.ActivePresentation.Slides.Add PPApp.ActivePresentation.Slides.Count + 1, ppLayoutBlank
PPApp.ActiveWindow.View.GotoSlide PPApp.ActivePresentation.Slides.Count
chr.Select
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
PPApp.ActiveWindow.View.Paste
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
Next chr
PPApp.Visible = True
End Sub
Code with function for plotting 6 charts from Excel to PPT
Option Base 1
Public ppApp As PowerPoint.Application
Sub CopyChart()
Dim wb As Workbook, ws As Worksheet
Dim oPPTPres As PowerPoint.Presentation
Dim myPPT As String
myPPT = "C:\LearnPPT\MyPresentation2.pptx"
Set ppApp = CreateObject("PowerPoint.Application")
'Set oPPTPres = ppApp.Presentations("MyPresentation2.pptx")
Set oPPTPres = ppApp.Presentations.Open(Filename:=myPPT)
ppApp.Visible = True
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
i = 1
For Each shp In ws.Shapes
strShapename = "C" & i
ws.Shapes(shp.Name).Name = strShapename
'shpArray.Add (shp)
i = i + 1
Next shp
Call Plot6Chart(oPPTPres, 2, ws.Shapes(1), ws.Shapes(2), ws.Shapes(3), ws.Shapes(4), ws.Shapes(5), ws.Shapes(6))
End Sub
Function Plot6Chart(pPres As Presentation, SlideNo As Long, ParamArray cCharts())
Dim oSh As Shape
Dim pSlide As Slide
Dim lLeft As Long, lTop As Long
Application.CutCopyMode = False
Set pSlide = pPres.Slides(SlideNo)
For i = 0 To UBound(cCharts)
cCharts(i).Copy
ppApp.ActiveWindow.View.GotoSlide SlideNo
pSlide.Shapes.Paste
Application.CutCopyMode = False
If i = 0 Then ' 1st Chart
lTop = 0
lLeft = 0
ElseIf i = 1 Then ' 2ndChart
lLeft = lLeft + 240
ElseIf i = 2 Then ' 3rd Chart
lLeft = lLeft + 240
ElseIf i = 3 Then ' 4th Chart
lTop = lTop + 270
lLeft = 0
ElseIf i = 4 Then ' 5th Chart
lLeft = lLeft + 240
ElseIf i = 5 Then ' 6th Chart
lLeft = lLeft + 240
End If
pSlide.Shapes(cCharts(i).Name).Left = lLeft
pSlide.Shapes(cCharts(i).Name).Top = lTop
Next i
Set oSh = Nothing
Set pSlide = Nothing
Set oPPTPres = Nothing
Set ppApp = Nothing
Set pPres = Nothing
End Function