Excel tabellen/grafieken automatisch plakken in PowerPoint

[Djani]

Hoi allemaal,

Op dit moment heb ik te maken met een enorme uitdaging, namelijk het automatiseren van PowerPoint presentaties via Excel. Ik heb een VBA script (werkt niet helemaal volledig) die meerdere tabellen - afkomstig van 1 en/of meerdere worksheets - in Excel automatisch plakt in PowerPoint, maar de grafieken blijkt die niet te pakken.
Ik werk met "ranges" via "Name Define", dus ik geef per sheet aan welke "range" gekopieerd en geplakt moet worden.

De rappportage kent vele sheets en daarbij is onderscheid gemaakt tussen tabellen en grafieken. Deze zitten in aparte tabbladen. De volgende logica heb ik gebruikt: een worksheet bevat meerdere "ranges", maar een sheet dat een grafiek/chart bevat, heeft geen enkele "range".

Option Explicit 
 
Sub PPT() 
     
    Dim iName As Long 
    Dim rName As Range 
    Dim nRange As Long 
    Dim dSlideCenter As Double 
    Dim pptApp As PowerPoint.Application 
    Dim pptPre As PowerPoint.Presentation 
    Dim pptSld As PowerPoint.Slide 
    Dim objSheet As Worksheet 
     
    Set pptApp = CreateObject("PowerPoint.Application") 
    Set pptPre = pptApp.Presentations.Add 
     
     ' loop the sheets
    For Each objSheet In ActiveWorkbook.Worksheets 
         
         'Create new slide for the data
        Set pptSld = pptPre.Slides.Add(pptPre.Slides.Count + 1, ppLayoutBlank) 
         
        If WorksheetFunction.Count(objSheet.UsedRange) > 0 Then 
             ' Data in sheet so copy used range(s)
             
            For iName = 1 To 2 
                 ' initialize
                Set rName = Nothing 
                nRange = 0 
                 
                 ' look for named range
                On Error Resume Next 
                Set rName = objSheet.Range("RangeToCopy" & CStr(iName)) 
                On Error GoTo 0 
                 
                If Not rName Is Nothing Then 
                     ' counter
                    nRange = nRange + 1 
                     ' copy range as picture
                    rName.CopyPicture Appearance:=xlScreen, Format:=xlPicture 
                     ' paste the copied picture
                    pptSld.Shapes.Paste 
                     
                     ' Align pasted shape
                    pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True 
                    pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True 
                End If 
            Next 
             
        Else 
             ' No data in sheet, so copy chart
            objSheet.ChartObjects(1).Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture 
             
             ' paste the copied picture
            pptSld.Shapes.Paste 
        End If 
         
         ' Align pasted shape
        pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True 
        pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True 
         
        If nRange = 2 Then 
            With ppSld.Shapes(ppSld.Shapes.Count - 1) ' first shape of two
                dSlideCenter = .Left + .Width / 2 
                .Left = 1.5 * dSlideCenter - .Width / 2 ' center shape in left half of slide
            End With 
            With ppSld.Shapes(ppSld.Shapes.Count) ' last shape of two
                .Left = 1.5 * dSlideCenter + .Width / 2 ' center shape in right half of slide
            End With 
        End If 
    Next 
End Sub

Echter, als ik de VBA script 'run', dan geeft die de volgende foutmelding: "Selection (unknown member): Invalid request. Nothing approriate is currently selected." Het lijkt fout te gaan bij het volgende stukje code: pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True.

Ervan uitgaande dat de script de (losstaande) grafiek zou pakken als het geen "range" bevat.

Het is redelijk lastig om uit te leggen, dus ik kan begrijpen dat er wellicht wat belangrijke informatie mist. Mocht dit het geval zijn, let me know!

Hebben jullie enige tips/tricks voor dit moeilijke vraagstuk?

Alvast bedankt allemaal!

Mvg,

Djani

 

[MDN111]

Dag Djani !

In de laatste coderegels staat een onbekende variabele:

If nRange = 2 Then 
    With [B][COLOR="#FF0000"]ppSld[/COLOR][/B].Shapes([COLOR="#FF0000"][B]ppSld[/B][/COLOR].Shapes.Count - 1) ' first shape of two
        dSlideCenter = .Left + .Width / 2 
        .Left = 1.5 * dSlideCenter - .Width / 2 ' center shape in left half of slide
    End With 
    With [COLOR="#FF0000"][B]ppSld[/B][/COLOR].Shapes([COLOR="#FF0000"][B]ppSld[/B][/COLOR].Shapes.Count) ' last shape of two
        .Left = 1.5 * dSlideCenter + .Width / 2 ' center shape in right half of slide
    End With 
End If

Volgens mij moet dat zijn: pptSld


Dat lijkt mij echter niet de reden van de foutmelding. In de coderegel(s) die de fout veroorzaken is er sprake van ActiveWindow.Selection. De PPT-Application draait echter in de achtergrond, dus is er misschien geen ActiveWindow en kan er waarschijnlijk niets geselecteerd zijn. Probeer de volgende code eens:

' [COLOR="#008000"]Align pasted shape
'pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
'pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True[/COLOR]
pptSld.Shapes.Range.Align msoAlignCenters, True
pptSld.Shapes.Range.Align msoAlignMiddles, True

Grtz,
MDN111.