Hallo!

Ich habe hier folgenden Code. Er soll per Klick auf einen Button alle Excel-Blätter in PowerPoint als neue Folie einfügen.

Existiert in einem Datenblatt ein Diagramm soll es als eigene Folie hinten dran gehängt werden.

Das funktioniert bei meinem Computer (mit Office 2003) auch. Auf einem anderen (ebenfalls 2003) leider nicht. Und ich kann mir nicht erklären, warum das so ist. :(

Er wirft die Meldung, dass nichts ausgewählt sei bei Zeile 53 ("With .ActiveWindow.Selection.ShapeRange.")

Könnt ihr mir bei der Lösung des Problems helfen, bitte?

Function GetTemplate()
  View.TextBox1.Text = "D:\SICHER\BK  NEU-ORGA\Vorlage.pot"
End Function

Sub CopyWksToPPT()
' Set a VBE reference to Microsoft PowerPoint Object Library
    Dim pptApp As Object
    Dim sTemplatePPt As String
    Dim wks As Worksheet
    Dim sTargetTop As Single
    Dim sTargetLeft As Single
    Dim sTargetWidth As Single
    Dim sTargetHeight As Single
    Dim sScaleHeight As Single
    Dim sScaleWidth As Single
    Dim iIndex As Integer
    Dim c As Integer

    'Change these as desired
    sTargetTop = 50
    sTargetLeft = 40
    sTargetWidth = 640
    sTargetHeight = 500
    sTemplatePPt = View.TextBox1.Text
    
    'Check for correct pot Template
    If sTemplatePPt = "" Then
      MsgBox "Bitte ein korrektes Powerpoint-Template angeben!"
    End If

    'Open new Powerpoint window
    iIndex = 2
    Set pptApp = CreateObject("Powerpoint.Application")
    With pptApp
        .Visible = True
        .Presentations.Open _
            Filename:=sTemplatePPt, Untitled:=msoTrue

        For Each wks In Worksheets
            wks.Select
            .ActiveWindow.View.GotoSlide _
                Index:=.ActivePresentation.Slides.Add _
                (Index:=iIndex, Layout:=ppLayoutTitleOnly).SlideIndex
                
            'Insert title
            .ActiveWindow.View.Slide.Shapes.Title.TextFrame.TextRange.Text = "Entwicklung " + Replace(ActiveWorkbook.Name, ".xls", "") + " in " + wks.Name
            
            iIndex = iIndex + 1
            wks.UsedRange.Copy
            
            'Insert table
            .ActiveWindow.View.Paste
            With .ActiveWindow.Selection.ShapeRange
                sScaleHeight = sTargetHeight / .Height
                sScaleWidth = sTargetWidth / .Width
                If sScaleHeight < sScaleWidth Then
                    sScaleWidth = sScaleHeight
                Else
                    sScaleHeight = sScaleWidth
                End If
                .ScaleHeight sScaleHeight, 0, 2
                .ScaleWidth sScaleWidth, 0, 2
                .Top = sTargetTop + (sTargetHeight - .Height) / 2
                .Left = sTargetLeft + (sTargetWidth - .Width) / 2
            End With
            
            'Insert possible charts on this worksheet
            '-----------------------------------------
            
            ' Reference existing instance of PowerPoint
            Set PPApp = GetObject(, "Powerpoint.Application")
            ' Reference active presentation
            Set PPPres = PPApp.ActivePresentation
            PPApp.ActiveWindow.ViewType = ppViewSlide

            For iCht = 1 To ActiveSheet.ChartObjects.Count
            With ActiveSheet.ChartObjects(iCht).Chart
    
                ' get chart title
                If .HasTitle Then
                    sTitle = .ChartTitle.Text
                Else
                    sTitle = ""
                End If
    
                ' remove title (or it will be redundant)
                .HasTitle = False
                ' copy chart as a picture
                .CopyPicture _
                    Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
                ' restore title
                If Len(sTitle) > 0 Then
                    .HasTitle = True
                    .ChartTitle.Text = sTitle
                End If
            End With
    
            ' Add a new slide and paste in the chart
            Set PPSlide = PPPres.Slides.Add(Index:=iIndex, Layout:=ppLayoutTitleOnly)
            PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
            
            iIndex = iIndex + 1
    
            With PPSlide
                ' paste and select the chart picture
                .Shapes.Paste.Select
                
                'scale chart
                With PPApp.ActiveWindow.Selection.ShapeRange
                sScaleHeight = sTargetHeight / .Height
                sScaleWidth = sTargetWidth / .Width
                If sScaleHeight < sScaleWidth Then
                    sScaleWidth = sScaleHeight
                Else
                    sScaleHeight = sScaleWidth
                End If
                .ScaleHeight sScaleHeight, 0, 2
                .ScaleWidth sScaleWidth, 0, 2
                .Top = sTargetTop + (sTargetHeight - .Height) / 2
                .Left = sTargetLeft + (sTargetWidth - .Width) / 2
                End With
                
                .Shapes.Placeholders(1).TextFrame.TextRange.Text = sTitle
            End With
            Next

            '---------------------------
            'END CHARTS
            
        Next
        .Visible = True
        
        'Go back to first Slide and fill in Title
        .ActiveWindow.View.GotoSlide 1
        .ActiveWindow.View.Slide.Shapes.Title.TextFrame.TextRange.Text = Replace(ActiveWorkbook.Name, ".xls", "")
    End With
    
End Sub

Sub Auto_Open()
  View.Show
  GetTemplate
End Sub

Function CopyCharts(PPPres As PowerPoint.Application)

  For iCht = 1 To ActiveSheet.ChartObjects.Count
    With ActiveSheet.ChartObjects(iCht).Chart
    
    ' get chart title
    If .HasTitle Then
        sTitle = .ChartTitle.Text
    Else
        sTitle = ""
    End If
    
    ' remove title (or it will be redundant)
    .HasTitle = False
    ' copy chart as a picture
    .CopyPicture _
        Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
    ' restore title
    If Len(sTitle) > 0 Then
        .HasTitle = True
        .ChartTitle.Text = sTitle
    End If
    End With
    
    ' Add a new slide and paste in the chart
    SlideCount = PPPres.Slides.Count
    Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutTitleOnly)
    PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
    
    With PPSlide
        ' paste and select the chart picture
        .Shapes.Paste.Select
        ' align the chart
        PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
        PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
        .Shapes.Placeholders(1).TextFrame.TextRange.Text = sTitle
    End With
  Next

End Function