Using Macros to Make Powerpoint Slides from Excel
Results 1 to 2 of 2

Thread: Using Macros to Make Powerpoint Slides from Excel
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    New Member
    Join Date
    Aug 2019
    Post Thanks / Like
    0 Post(s)
    0 Thread(s)

    Default Using Macros to Make Powerpoint Slides from Excel


    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...

    Your help would be greatly appreciated. Thanks.

  2. #2
    Board Regular pbornemeier's Avatar
    Join Date
    May 2005
    Virginia Beach, VA USA
    Post Thanks / Like
    0 Post(s)
    1 Thread(s)

    Default Re: Using Macros to Make Powerpoint Slides from Excel

    Have not tried this on a Mac, but it works on Win10/Office 2016

    Option Explicit
    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:
        '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
            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 If
        'Set output path
        If ThisWorkbook.Path = vbNullString Then
            sOutputPath = Environ("userprofile") & "\Documents\"
            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 _
        ' Copy specified range as picture
        If TypeName(varCopyWhat) = "Range" Then
            wksFrom.Range(sRangeFrom).CopyPicture Appearance:=xlScreen, Format:=xlPicture
            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
                sngScale = sngWidthScale
            End If
            With PPApp.ActiveWindow.Selection.ShapeRange
                .ScaleWidth 1 / sngScale, msoFalse, msoScaleFromTopLeft
                .ScaleHeight 1 / sngScale, msoFalse, msoScaleFromTopLeft
            End With
            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
        ' Clean up
        Set PPSlide = Nothing
        Set PPPres = Nothing
        Set PPApp = Nothing
    End Sub

    - Use CODE tags to keep your code formatted. See: BB Tags
    - How to attach Screenshots
    - Try searching for your answer first, see how
    - Test and validate results for all code on a copy of your worksheet!! How do you use the code you just found?
    - Posting guidelines, forum rules and terms of use
    - Read the FAQs

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts