[VBA] Use company specific template to copy from Excel to Powerpoint

joepACN

New Member
Joined
Jul 6, 2015
Messages
3
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:


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
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Hi joecpACN - Welcome to the forum. As nobody has replied I thought I would try to help get this thread going. If the above code is working perfectly, have you tried applying the template to PowerPoint after running this and transferring the data? You should be able to alter the PP template after the data has been transferred by the macro. Hope this helps.
 
Upvote 0
Hi,

Thanks a lot! I decided to stick to the blank powerpoint sheet but to simply paste a picture (enhanced metafile) of the companies logo from Excel to the upper right corner each slide - that is fine enough. This works perfectly on the first slide but sometime VBA gets stuck when I redo/repeat this for every slide. Does anyone have an idea how to not copy the picture from Excel each time but rather copy the picture for slide 1 from Excel and for slide 2 to n from the first .ppt slide? I can't get this to work.

My code to copy the picture from Excel to the first slide is:

Code:
 'ABN LOGO
        
         Start.Range(Start.Cells(1, 2), Start.Cells(3, 6)).Copy
        
        'Paste to PowerPoint and position
         pptSlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
                         
        'Picture position.
         With pptSlide.Shapes(5)
              .name = "ABN LOGO"
              .Top = 20
              .Left = 735
              .Height = 80
              .Width = 200
         End With
            
         'Clear The Clipboard
         Application.CutCopyMode = False
Thanks a lot!

Best,
Joep
 
Upvote 0

Forum statistics

Threads
1,213,557
Messages
6,114,293
Members
448,564
Latest member
ED38

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top