Hi All,
I wrote a macro to copy different graphs and tables from Excel to a (new) powerpoint presentation and it works perfectly.
However, it copies the graphs and tables into a blank powerpoint template while I want to use a specific company template (with logo etc) and I can't get this to work (already tried different options). Does anyone have suggestions?
Currently the code I have (that works but uses a blank powerpoint) is like:
I hope someone can help me! Thanks a lot in advance
Best,
Joep
I wrote a macro to copy different graphs and tables from Excel to a (new) powerpoint presentation and it works perfectly.
However, it copies the graphs and tables into a blank powerpoint template while I want to use a specific company template (with logo etc) and I can't get this to work (already tried different options). Does anyone have suggestions?
Currently the code I have (that works but uses a blank powerpoint) is like:
Code:
'Declaring the necessary Power Point variablesDim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptSlideCount As Integer
Sub Generatereport()
Dim ws, Graphs, Tables As Worksheet
Dim db As Workbook
Dim RowNumber As Integer
Dim objCh As Object
Dim chTitle As String
Dim rng As Range
strworkbookname = ActiveWorkbook.name
Set db = Workbooks(CStr(strworkbookname))
Set Graphs = db.Worksheets("Graphs")
Set Tables = db.Worksheets("Tables")
'Open PowerPoint and create a new presentation.
Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Add
For Each ws In db.Worksheets
If Len(ws.name) = 4 Then
'Count the slides and add a new one after the last slide.
pptSlideCount = pptPres.Slides.Count
Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)
For Each objCh In Graphs.ChartObjects
chTitle = objCh.Chart.ChartTitle.Text
If InStr(chTitle, ws.name) > 0 Then
Dim j As Integer
objCh.Chart.ChartArea.Copy
'Paste the chart and create a new textbox.
pptSlide.Shapes.PasteSpecial ppPasteJPG
'Format the picture
For j = 1 To pptSlide.Shapes.Count
With pptSlide.Shapes(j)
'Picture position.
If .Type = msoPicture Then
.Top = 80 + (j - 1) * 225
.Left = 30
.Height = 350
.Width = 500
End If
End With
Next j
End If
Next objCh
'TABLES
With Tables
Set FindRow = .Range("B:B").Find(What:=CStr(ws.name), LookIn:=xlValues)
End With
If Not FindRow Is Nothing Then
RowNumber = FindRow.Row
Tables.Range(Tables.Cells(RowNumber, 2), Tables.Cells(RowNumber + 12, 6)).Copy
'Paste to PowerPoint and position
pptSlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
'Picture position.
With pptSlide.Shapes(3)
.Top = 80
.Left = 550
.Height = 350
.Width = 380
End With
'Clear The Clipboard
Application.CutCopyMode = False
End If
End If
Next ws
'Show the power point.
pptApp.Visible = True
'Cleanup the objects.
Set pptSlide = Nothing
Set pptPres = Nothing
Set pptApp = Nothing
'Infrom the user that the macro finished.
MsgBox "The charts were copied successfully to the new presentation!", vbInformation, "Done"
End Sub
I hope someone can help me! Thanks a lot in advance
Best,
Joep