none
- VBA to copy excel table into powerpoint

    Question

  • I am trying to create PowerPoint slides from an access database, basically the data is queried in access, pasted and formatted into Excel and then copied into PowerPoint.  The program loops through different data (cities) and create a series of slides based on the results for each city.  When I had a small number of cities (35) the program worked fine, now that I increased the number of cities (160) the program fails, I get a runtime error

    Here is a snippet of the code and where it is failing, after looping through about 90 times the program fails on the last section, objPPTSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile).Name = "SummaryTableOne".  Any ideas or advice would be greatly appreciated.

    Option Compare Database

    Option Explicit

     

    Sub CreateSlides()

         Dim datDate0, datDate1, datDate2, datDate3 As Date

        Dim intCurrentSheet, intDMACount, intStartCopy, intEndCopy As Integer

        Dim db As DAO.Database

        DoCmd.SetWarnings False

        gstrPath = "C:\USER\Data\"

        'Create Application Variables

        '*Excel

        Dim xlApp As Excel.Application

        Dim xlWorkbookC As Excel.Workbook

        Dim xlWorkbookTemp As Excel.Workbook

        Dim xlSheetSlide0, xlSheetSlide1, xlSheetSlide2, xlSheetSlide2U, xlSheetSlide3, xlSheetSlideTemp As Excel.Worksheet

        '*Powerpoint

        Dim objPPTApp As PowerPoint.Application

        Dim objPPTPresen As PowerPoint.Presentation

        Dim objPPTSlide As PowerPoint.Slide

        Dim objPPTShape As PowerPoint.Shape

     

     'Open Excel Application

        Set xlApp = CreateObject("Excel.Application")

        xlApp.Visible = True

        Set xlWorkbookC = xlApp.Workbooks.Open(gstrPath & "DMATemplate.xlsm")

        Set xlSheetSlide0 = xlWorkbookC.Sheets("Page_01")

        Set xlSheetSlide1 = xlWorkbookC.Sheets("Slides")

        Set xlSheetSlide2 = xlWorkbookC.Sheets("Slide2A")

        Set xlSheetSlide2U = xlWorkbookC.Sheets("Slide2B")

        Set xlSheetSlide3 = xlWorkbookC.Sheets("Page_99")

        'Open Powerpoint Application

        Set objPPTApp = CreateObject("Powerpoint.Application")

        objPPTApp.Visible = True

        Set objPPTPresen = objPPTApp.Presentations.Open(gstrPath & "Template.pptm")

        With objPPTPresen.Slides

            Set objPPTSlide = .Item(1)

        End With

     

        'Create Slide 1

        With objPPTPresen.Slides

            s = objPPTPresen.Slides.Count

            Set objPPTSlide = .Add(s, ppLayoutBlank)

        End With

        'Create Slide1

        Set objPPTShape = objPPTSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, _

            Left:=18, Top:=18, Width:=600, Height:=50)

        With objPPTShape

            .TextFrame.TextRange.Font.Name = "Verdana"

            .TextFrame.TextRange.Font.Bold = msoTrue

            .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft

            .TextFrame.TextRange.Text = "Advance 12M Sales Growth vs. Remaining Market"

            .TextFrame.TextRange.Lines(1).Font.Size = 18

        End With

     

           With objPPTPresen.Slides

                s = objPPTPresen.Slides.Count

                Set objPPTSlide = .Add(s, ppLayoutBlank)

            End With

     

            Set objPPTShape = objPPTSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, _

                Left:=18, Top:=18, Width:=600, Height:=50)

            With objPPTShape

                .TextFrame.TextRange.Font.Name = "Verdana"

                .TextFrame.TextRange.Font.Bold = msoTrue

                .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft

                .TextFrame.TextRange.Text = "Advance 12M Sales Growth vs. Remaining Market"

                .TextFrame.TextRange.Lines(1).Font.Size = 18

            End With

           

            xlSheetSlide0.Select

            xlSheetSlide0.Range(strCopyRange).Copy

           

            objPPTSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile).Name = "SummaryTableOne"

            With objPPTShape

              .ScaleHeight 0.4, msoTrue, msoScaleFromMiddle

              .ScaleWidth 0.8, msoTrue, msoScaleFromMiddle

              .Top = 75

              .Left = 18

          End With

    Wednesday, April 13, 2011 8:28 PM

All replies

  • Does anyone have any advice on an alternative way to do this.  Essentially I want to create a PowerPoint deck with charts and data tables from Excel, I thought my best bet would be to paste pictures into PowerPoint, but I keep getting the following error:

    run-time error '-2147417851 (80010105)';
    Method 'PasteSpecial' of obejct 'Shapes' failed

    Would I be better off just pasting the chart as an object.  Any thoughts or advice on this error would be greatly appreciated.

    Thanks

    Thursday, April 21, 2011 3:14 PM
  • I export XL charts for word doc.  I save them to a temp dir and then insert them into a word template.  I have seen no problem with the number of charts.

     

         Set wkBook = xlApp.Workbooks.Open("C:\temp\charts.xls")
        chrtCnt = wkBook.Charts.Count
        For i = 1 To chrtCnt
          idxI = Right("000" & i, 3)
          Application.StatusBar = "Exporting from wookbook: WrkBk" & k + 1 & ", chart: " & i
          wkBook.Charts(i).Height = 550
          wkBook.Charts(i).Width = 740
          saveOrient = wkBook.Charts(i).PageSetup.Orientation
          wkBook.Charts(i).PageSetup.Orientation = xlLandscape
          fName = chartDirTemp & "\WrkBk" & idxK & "_Chart" & idxI & ".gif"
          wkBook.Charts(i).Export fileName:=fName, FilterName:="GIF"
          wkBook.Charts(i).PageSetup.Orientation = saveOrient
        Next i

    Thursday, April 21, 2011 5:58 PM