Using Macros to Make Powerpoint Slides from Excel

adelm

New Member
Joined
Aug 4, 2019
Messages
1
Hello,

I am trying very hard to find a solution to this but so far nothing works... how can I write a code for a macro that takes a chart or table or cell from Excel and uses it to create the respective Powerpoint slides? Anyone have experience with this?

Furthermore, I am using Mac currently but if need be I'll switch to a Windows computer. So far I've tried the following with varying degrees of success. Something worked at one point but I cannot remember which it was for the life of me...
https://www.dummies.com/software/microsoft-office/excel/sending-excel-data-to-a-powerpoint-presentation/
https://www.thespreadsheetguru.com/blog/2014/3/17/copy-paste-an-excel-range-into-powerpoint-with-vba

Your help would be greatly appreciated. Thanks.
 

pbornemeier

Well-known Member
Joined
May 24, 2005
Messages
3,725
Have not tried this on a Mac, but it works on Win10/Office 2016

Code:
Option Explicit

'https://www.mrexcel.com/forum/excel-questions/1105935-using-macros-make-powerpoint-slides-excel.html
    
Sub Test_CopyItemToPPT()

        CopyItemToPPT Worksheets("Sheet1"), Worksheets("Sheet1").ChartObjects(1), "Chart"
        CopyItemToPPT Worksheets("Sheet1"), Range("A1"), "Cell"
        CopyItemToPPT Worksheets("Sheet1"), Range("A1:H20"), "Range"
        CopyItemToPPT Worksheets("Sheet1"), Selection, TypeName(Selection)
        
End Sub
Sub CopyItemToPPT(wksFrom As Worksheet, varCopyWhat As Variant, sSlideName As String)
    'Will copy wksFrom!Range(sRangeFrom) to the end of the open PPT
    '  (or create a PPT if none open) with a slide name of sSlideName
    
    'Code modified from:
    'http://peltiertech.com/Excel/XL_PPT.html
    'Sub ExcelToExistingPowerPoint()
    
    Dim PPApp As Object ' As PowerPoint.Application
    Dim PPPres As Object ' As PowerPoint.Presentation
    Dim PPSlide As Object ' As PowerPoint.Slide
    Dim ppShape As Object
    Dim sngHeightScale As Single
    Dim sngWidthScale As Single
    Dim sngScale As Single
    Dim sOutputSheet As String  'Name of sheet that will be copied
    Dim sOutputPath As String
    Dim sRangeFrom As String
    Dim sngHeight As Single
    Dim sngWidth As Single
    Dim sPPTName As String
    
    'What is being copied?  Save its height and width
    If TypeName(varCopyWhat) = "Range" Then
        'That is OK
        sRangeFrom = varCopyWhat.Address
        sngHeight = varCopyWhat.Height
        sngWidth = varCopyWhat.Width
    ElseIf TypeName(varCopyWhat.Parent) = "Chart" Then
        'That is OK
        Set varCopyWhat = varCopyWhat.Parent
        sngHeight = varCopyWhat.Parent.Height
        sngWidth = varCopyWhat.Parent.Width
        sSlideName = TypeName(varCopyWhat)
    ElseIf TypeName(varCopyWhat) = "ChartObject" Then
        'That is OK
        sngHeight = varCopyWhat.Height
        sngWidth = varCopyWhat.Width
    Else
        MsgBox "The typename for the object to be copied is " & TypeName(varCopyWhat) & "." & vbLf & vbLf & _
            "This code is not currently designed to copy it to PPT.  Exiting", , "Can't Copy Item"
        End
    End If
    
    
    
    'Set output path
    If ThisWorkbook.Path = vbNullString Then
        sOutputPath = Environ("userprofile") & "\Documents\"
    Else
        sOutputPath = ThisWorkbook.Path & "\"
    End If
    
    ' Reference instance of PowerPoint, using late binding so PPT reference does not have to be added
    On Error Resume Next
    ' Check whether PowerPoint is running
    Set PPApp = GetObject(, "PowerPoint.Application")
    If PPApp Is Nothing Then
        ' PowerPoint is not running, create new instance
        Set PPApp = CreateObject("PowerPoint.Application")
        ' For automation to work, PowerPoint must be visible
        PPApp.Visible = True
    End If
    On Error GoTo 0
    
    ' Reference existing instance of PowerPoint
    Set PPApp = GetObject(, "Powerpoint.Application")
        
    'If there is no Presentation in PPApp, create one with YYYYMMDD hhmmss as the presentation name
    '  and a first sheet containing that name
    sPPTName = Format(Now(), "yyyymmdd hhmmss")
    If PPApp.Presentations.Count = 0 Then
        PPApp.Presentations.Add WithWindow:=msoTrue
        If Left(PPApp.Presentations(1).Name, 10) = "Presentati" Then  '
            PPApp.Presentations(1).Slides.Add PPApp.ActivePresentation.Slides.Count + 1, 11
            PPApp.ActiveWindow.Selection.SlideRange.Shapes("Title 1").TextFrame2.TextRange.Text = sPPTName
            PPApp.Presentations(1).SaveAs Filename:=sOutputPath & sPPTName
        End If
        'PPApp.Presentations.Add WithWindow:=msoTrue  'sometimes needed 2nd to get any to show up
    End If
    
    ' Reference active presentation
    Set PPPres = PPApp.ActivePresentation
    PPApp.ActiveWindow.ViewType = 1 ' 1 = ppViewSlide
    
    'Position PPT window
    Dim sngScreenWidth As Single
    Dim sngScreenHeight As Single
    Dim sngRibbonHeight1 As Single
    Dim sngRibbonHeight2 As Single
    With PPApp
        .WindowState = 3 'ppWindowMaximized
        sngScreenWidth = .Width
        sngScreenHeight = .Height
        .WindowState = 1 'ppWindowNormal
        .Width = sngScreenWidth / 3
        .Height = sngScreenHeight / 2
        .Left = 2 * .Width
        .Top = .Height
        'Collapse Ribbon if visible
        If .CommandBars("Ribbon").Height > 100 Then _
            .CommandBars.ExecuteMso ("MinimizeRibbon")
        .ActivePresentation.PageSetup.SlideSize = 2 ' ppSlideSizeLetterPaper
        'Fit Presentation in PPT Window
        '.ActiveWindow.View.Zoom = 40
        PPApp.ActiveWindow.View.Zoomtofit = msoTrue  'Does not work
    End With
    
    ' Create & Reference new active slide
    PPApp.ActivePresentation.Slides.Add PPApp.ActivePresentation.Slides.Count + 1, 11 'ppLayoutTitleOnly = 11 ppLayoutBlank = 12
    PPApp.ActiveWindow.View.GotoSlide Index:=PPApp.ActivePresentation.Slides.Count
    Set PPSlide = PPPres.Slides _
        (PPApp.ActivePresentation.Slides.Count)
    
    ' Copy specified range as picture
    If TypeName(varCopyWhat) = "Range" Then
        wksFrom.Range(sRangeFrom).CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Else
        varCopyWhat.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    End If
    
    
    ' Paste image
    PPApp.Visible = True    'Got to be visible to paste to it
    'PPSlide.Shapes.Paste.Select    'Used to work !
    Set ppShape = PPSlide.Shapes.Paste
    
    'Reset pasted image to original aspect ratio (can get stretched during paste)
    PPApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = False
    PPApp.ActiveWindow.Selection.ShapeRange.Height = sngHeight
    PPApp.ActiveWindow.Selection.ShapeRange.Width = sngWidth
    PPApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = True
    
    'Resize &  Align pasted image to fit PPT page
    sngHeightScale = PPApp.ActiveWindow.Selection.ShapeRange.Height / PPPres.PageSetup.SlideHeight
    sngWidthScale = PPApp.ActiveWindow.Selection.ShapeRange.Width / (PPPres.PageSetup.SlideWidth)
    If sngWidthScale > 1 Or sngHeightScale > 1 Then
        'At least 1 dimension too big scale down, lock ratio
        If sngHeightScale > sngWidthScale Then
            sngScale = sngHeightScale
        Else
            sngScale = sngWidthScale
        End If
        
        With PPApp.ActiveWindow.Selection.ShapeRange
            .ScaleWidth 1 / sngScale, msoFalse, msoScaleFromTopLeft
            .ScaleHeight 1 / sngScale, msoFalse, msoScaleFromTopLeft
        End With
    Else
        With PPApp.ActiveWindow.Selection.ShapeRange
'            .ScaleWidth 1, msoTrue, msoScaleFromTopLeft
'            .ScaleHeight 1, msoTrue, msoScaleFromTopLeft
        End With
    End If
        
    With PPApp.ActiveWindow.Selection.ShapeRange
        .Align msoAlignCenters, True
        .Align msoAlignMiddles, True
        .IncrementTop 18
    End With
    
    With PPApp.ActiveWindow.Selection.SlideRange.Shapes("Title 1")
        .TextFrame.WordWrap = msoFalse
        .TextFrame2.TextRange.Text = sSlideName
        .TextFrame2.TextRange.Font.Size = 14
        .TextFrame.AutoSize = 1 'ppAutoSizeShapeToFitText
        .Left = 10
        .Top = 10
    End With
    
    'Stop
    
    ' Clean up
    Set PPSlide = Nothing
    Set PPPres = Nothing
    Set PPApp = Nothing

End Sub
 

Forum statistics

Threads
1,082,588
Messages
5,366,490
Members
400,895
Latest member
shumcal

Some videos you may like

This Week's Hot Topics

Top