Hallo,

ich möchte gerne Datensätze von Excel in Powerpoint transportieren.

Ich habe bereits einen Code gefunden. Das Problem ist nur: Das Excel- Blatt schließt sich, nachdem der Code angewendet wurde und ich möchte, dass sich Powerpoint nach der Übertragung der Datensätze öffnet.

Habt ihr hierzu Ideen?

Option Explicit
Private Declare Function GetWindowText Lib "user32" _
    Alias "GetWindowTextA" (ByVal hwnd As Long, _
    ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function FindWindow Lib "user32" _
    Alias "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal _
    hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function GetWindow Lib "user32" _
    (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias _
    "GetTempPathA" (ByVal strBufferLength As Long, ByVal _
    lpBuffer As String) As Long
Private Declare Function GetParent Lib "user32" _
    (ByVal hwnd As Long) As Long
Const strPPSave As String = "Test.ppt" ' anpassen!!!
Const GW_HWNDNEXT = 2
Const SW_MINIMIZE = 6
Dim objPPApp As Object
Public Sub PowerPoint_Slide()
    Application.ScreenUpdating = False
    On Error GoTo Fin
    On Error Resume Next
    Set objPPApp = GetObject(, "PowerPoint.Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objPPApp = CreateObject("PowerPoint.Application")
            If Err.Number > 0 Then
                MsgBox Err.Number & " " & Err.Description
                Set objPPApp = Nothing
                Exit Sub
            End If
        Case 0
        Case Else
            MsgBox Err.Number & " " & Err.Description
            Set objPPApp = Nothing
            Exit Sub
    End Select
    On Error GoTo 0
    On Error GoTo Fin
    Call Do_PowerPoint
Fin:
    If Err.Number <> 0 Then
        If Err.Number = 13 Then
            MsgBox "Inputbox - Rangeauswahl abgebrochen!"
        Else
            MsgBox "Fehler: " & Err.Number & " " & Err.Description
        End If
    End If
    If Not objPPApp Is Nothing Then objPPApp.Quit
    Set objPPApp = Nothing
    With Application
        .ScreenUpdating = True
        .CutCopyMode = False
        .ThisWorkbook.Close False
    End With
End Sub
Private Sub Do_PowerPoint()
    Dim objPPSlide As Object
    Dim objPPPraes As Object
    Dim strFolder As String
    Dim intCount As Integer
    Dim objShape As Object
    Dim varTMP As Variant
    Dim intTMP As Integer
    With objPPApp
        Set objPPPraes = .Presentations.Add
        Call PP_Klein
        For intCount = 1 To 2 ' Schleifendurchlauf anpassen!!!
            Application.ScreenUpdating = True
            Set varTMP = Application.InputBox _
                ("Range", "Auswahl", , , , , , 8)
            Application.ScreenUpdating = False
            With ThisWorkbook.Worksheets(varTMP.Parent.Name)
                .Range(varTMP.Address).Copy
            End With
            'Const ppLayoutBlank = 12
            Set objPPSlide = objPPPraes.Slides.Add _
                (intCount + intTMP, 12)
            intTMP = intTMP + 1
            'Const ppPasteOLEObject = 10
            'Const msoTrue = -1 (Element von Office.MsoTriState)
            objPPSlide.Shapes.PasteSpecial 10, , , , , -1
            Set objPPSlide = objPPPraes.Slides.Add _
                (intCount + intTMP, 12)
            intTMP = intTMP + 1
            'Const ppPasteEnhancedMetafile = 2
            objPPSlide.Shapes.PasteSpecial 2
            Set objShape = objPPPraes.Slides.Item(objPPPraes.Slides.Count)
            With objShape.Shapes.Item(objShape.Shapes.Count)
                .Top = 60
                .Left = 60
                .Width = 350
                .Height = 350
            End With
            Set objPPSlide = objPPPraes.Slides.Add _
                (intCount + intTMP, 12)
            With ThisWorkbook.Worksheets(varTMP.Parent.Name)
                .Range(varTMP.Address).CopyPicture
            End With
            objPPSlide.Shapes.Paste
            Set objShape = objPPPraes.Slides.Item(objPPPraes.Slides.Count)
            With objShape.Shapes.Item(objShape.Shapes.Count)
                .Top = 60
                .Left = 60
                .Width = 350
                .Height = 350
            End With
            Application.ScreenUpdating = True
            Application.CutCopyMode = False
            Set objShape = Nothing
            Set objPPSlide = Nothing
            Set varTMP = Nothing
        Next intCount
        ' speichert auf dem Desktop
        strFolder = Environ("UserProfile") & "\Desktop\"
        If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
        ' speichert im TEMP-Ordner
        'strFolder = PP_Save
        objPPPraes.SaveAs strFolder & strPPSave
    End With
    Set objPPPraes = Nothing
End Sub
Private Sub PP_Klein()
    Dim hWindow As Long
    hWindow = SearchHndByWndName_Parent("Microsoft PowerPoint")
    Call ShowWindow(hWindow, SW_MINIMIZE)
End Sub
Private Function SearchHndByWndName_Parent(strSearch As String) As Long
    Dim strTMP As String * 100
    Dim nhWnd As Long
    nhWnd = FindWindow(vbNullString, vbNullString)
    Do While Not nhWnd = 0
        If GetParent(nhWnd) = 0 Then
            GetWindowText nhWnd, strTMP, 100
            If InStr(strTMP, strSearch) > 0 Then
                SearchHndByWndName_Parent = nhWnd
                Exit Do
            End If
        End If
        nhWnd = GetWindow(nhWnd, GW_HWNDNEXT)
    Loop
End Function
Private Function PP_Save() As String
    Dim strBuffer As String
    Dim lngReturn As Long
    strBuffer = Space(255)
    lngReturn = GetTempPath(255, strBuffer)
    If lngReturn > 0 Then
        PP_Save = Left$(strBuffer, lngReturn)
    Else
        PP_Save = CurDir$
    End If
    If Right(PP_Save, 1) <> "\" Then PP_Save = PP_Save & "\"
End Function